From f0a7903c00164598347d22378492c9186a7b16e6 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 4 Feb 2021 00:08:20 +0100 Subject: [PATCH 0001/1015] Add input check --- src/tools/scamv/examples/scripts/1-gen.sh | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/tools/scamv/examples/scripts/1-gen.sh b/src/tools/scamv/examples/scripts/1-gen.sh index 5d228874e..57a2077e8 100755 --- a/src/tools/scamv/examples/scripts/1-gen.sh +++ b/src/tools/scamv/examples/scripts/1-gen.sh @@ -10,6 +10,12 @@ SCAMV_EXAMPLES_DIR=$(dirname "${BASH_SOURCE[0]}") SCAMV_EXAMPLES_DIR=$(readlink -f "${SCAMV_EXAMPLES_DIR}/..") HOLBA_DIR=$(readlink -f "${SCAMV_EXAMPLES_DIR}/../../../..") +# check inputs +if [[ -z "${EXPGENRUN_ID_PARAM}" ]]; then + echo "ERROR: please provide both, run description (simple string prefix) and expgenrun id (text file with scamv specification)" + exit 1 +fi + # find the environment source "${HOLBA_DIR}/env.sh" echo "============================" From f0dd7f969d691c0b80b0984fcd5cae2709cf2f59 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 24 Oct 2020 11:18:47 +0200 Subject: [PATCH 0002/1015] Add TODOs --- src/shared/bir_smtLib.sml | 2 ++ src/shared/examples/test-smtLib.sml | 10 ++++++++++ 2 files changed, 12 insertions(+) diff --git a/src/shared/bir_smtLib.sml b/src/shared/bir_smtLib.sml index 492883d6c..d3633fc68 100644 --- a/src/shared/bir_smtLib.sml +++ b/src/shared/bir_smtLib.sml @@ -561,6 +561,8 @@ BExp_Store (BExp_Den (BVar "fr_269_MEM" (BType_Mem Bit32 Bit8))) end end; +(* TODO: add a model importer *) + end (* local *) end (* struct *) diff --git a/src/shared/examples/test-smtLib.sml b/src/shared/examples/test-smtLib.sml index b3450d53f..dc0586f0b 100644 --- a/src/shared/examples/test-smtLib.sml +++ b/src/shared/examples/test-smtLib.sml @@ -84,3 +84,13 @@ val _ = List.map (fn (exp, expected) => raise Fail ("unexpected export: " ^ (term_to_string exp))); in () end) exporting_exp_testcases; +(* TODO: need a bunch of test cases that can be automatically checked, + such that we know what's supposed to come out. + maybe use EVAL and BIR semantics together with z3's simplify? +*) + +(* TODO: addition to the last TODO. with a model importer we can check a full round: + - send query based on BIR expression + - get model satisfying BIR expression in terms of bir var assignments + - evaluate model on BIR expression +*) From 5b9fe8a21c76a115ca32363cbd9e5b589f9acc9d Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 5 Feb 2021 20:55:34 +0100 Subject: [PATCH 0003/1015] Add notes and little adjustments --- .../scamv/persistence/embexp_logsLib.sig | 19 +++++- .../scamv/persistence/embexp_logsLib.sml | 61 +++++++++++-------- 2 files changed, 53 insertions(+), 27 deletions(-) diff --git a/src/tools/scamv/persistence/embexp_logsLib.sig b/src/tools/scamv/persistence/embexp_logsLib.sig index b09a21267..b8b3a88de 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sig +++ b/src/tools/scamv/persistence/embexp_logsLib.sig @@ -62,6 +62,14 @@ sig val get_prog_list_entries : prog_list_handle -> (int * prog_handle) list; val get_exp_list_entries : exp_list_handle -> (int * exp_handle ) list; + (* retrieval of list of whole entries *) +(* + val get_prog_list_entries_full : prog_list_handle -> (int * logs_prog) list; + val get_exp_list_entries_full : exp_list_handle -> (int * logs_exp ) list; +*) + (* TODO: after implementing get_prog_list_entries_full, remove the following ad-hoc hack *) + val hack_get_prog_list_by_listname : string -> logs_prog list; + (* (* retrieval of metdata *) val get_run_metadata : run_handle -> logs_meta list; @@ -87,8 +95,15 @@ sig Json.json option) list -> exp_handle list; *) - (* TODO: generalize this ad-hoc query *) - val hack_get_prog_list_by_listname : string -> logs_prog list; + + (* + most general query with raw input and raw output. + - ! it deliberately doesn't return handles so that links in the db cannot be messed up ! + - the returned json values are of one of the following types: NULL, NUMBER, STRING + *) +(* + val query_sql : string -> (string list * json.Json list list); +*) (* function to enable the testing mode, i.e., uses the testing db *) val set_testing : unit -> unit; diff --git a/src/tools/scamv/persistence/embexp_logsLib.sml b/src/tools/scamv/persistence/embexp_logsLib.sml index 58976d6d9..1499107fc 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sml +++ b/src/tools/scamv/persistence/embexp_logsLib.sml @@ -206,13 +206,13 @@ fun run_db_a_ignore t vs = case get_db_q (run_db_q_gen false t [(f_id, NUMBER id)]) of (_, [x]) => (case x of ARRAY vals => unpack_fun vals - | _ => raise ERR "get_all_ids" "result not as expected") - | _ => raise ERR "get_all_ids" "result not as expected"; + | _ => raise ERR "get_from_id" "result not as expected") + | _ => raise ERR "get_from_id" "result not as expected"; fun get_from_id_mult (t, f_id) unpack_fun id = case get_db_q (run_db_q_gen false t [(f_id, NUMBER id)]) of (_, xs) => List.map (fn x => case x of ARRAY vals => unpack_fun vals - | _ => raise ERR "get_all_ids_mult" "result not as expected") xs; + | _ => raise ERR "get_from_id_mult" "result not as expected") xs; fun get_from_ids (t, f_id) unpack_fun ids = List.map (fn id => get_from_id (t, f_id) unpack_fun id) ids; @@ -293,6 +293,23 @@ fun run_db_a_ignore t vs = unpack_list_entry id; + +(* +*) +val run_db_h = run_db "hack"; +fun run_db_h_gen tn = run_db_h ( + STRING tn); + + fun get_hack_from_id_mult unpack_fun tn = + case get_db_q (run_db_h_gen tn) of + (_, xs) => List.map (fn x => case x of + ARRAY vals => unpack_fun vals + | _ => raise ERR "get_all_ids_mult" "result not as expected") xs; + +fun hack_get_prog_list_by_listname listname = +get_hack_from_id_mult unpack_logs_prog listname; + + (* *) (* @@ -303,18 +320,7 @@ fun run_db_a_ignore t vs = *) -(* -*) - fun get_all_ids t = - case get_db_q (run_db_q_all true t) of - ([STRING s_id], jsonids) - => if s_id = "id" then List.map (fn x => case x of - ARRAY [NUMBER i] => i | _ => raise ERR "get_all_ids" "result not as expected") jsonids else - raise ERR "get_all_ids" "result not as expected" - | _ => raise ERR "get_all_ids" "result not as expected"; - fun query_all_prog_lists () = get_all_ids "exp_progs_lists"; - fun query_all_exp_lists () = get_all_ids "exp_exps_lists"; (* *) @@ -331,18 +337,23 @@ fun run_db_a_ignore t vs = (* *) -val run_db_h = run_db "hack"; -fun run_db_h_gen tn = run_db_h ( - STRING tn); - - fun get_hack_from_id_mult unpack_fun tn = - case get_db_q (run_db_h_gen tn) of - (_, xs) => List.map (fn x => case x of - ARRAY vals => unpack_fun vals - | _ => raise ERR "get_all_ids_mult" "result not as expected") xs; +(* + val query_match_runs : (string option * + prog_list_handle option * + exp_list_handle option) list + -> run_handle list; + val query_match_progs : (string option * + string option) + -> prog_handle list; + val query_match_exps : (prog_handle option * + string option * + string option * + Json.json option) list + -> exp_handle list; +*) -fun hack_get_prog_list_by_listname listname = -get_hack_from_id_mult unpack_logs_prog listname; +(* +*) end (* local *) From 07a342ab0ee73f6329ec00fa3a708bf1415d21c4 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 5 Feb 2021 22:17:57 +0100 Subject: [PATCH 0004/1015] Remove quickfix and add a fix --- .../scamv/persistence/embexp_logsLib.sig | 4 -- .../scamv/persistence/embexp_logsLib.sml | 65 +++++++++++++------ .../scamv/persistence/persistenceLib.sml | 7 +- 3 files changed, 47 insertions(+), 29 deletions(-) diff --git a/src/tools/scamv/persistence/embexp_logsLib.sig b/src/tools/scamv/persistence/embexp_logsLib.sig index b8b3a88de..a40a72e60 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sig +++ b/src/tools/scamv/persistence/embexp_logsLib.sig @@ -63,12 +63,8 @@ sig val get_exp_list_entries : exp_list_handle -> (int * exp_handle ) list; (* retrieval of list of whole entries *) -(* val get_prog_list_entries_full : prog_list_handle -> (int * logs_prog) list; val get_exp_list_entries_full : exp_list_handle -> (int * logs_exp ) list; -*) - (* TODO: after implementing get_prog_list_entries_full, remove the following ad-hoc hack *) - val hack_get_prog_list_by_listname : string -> logs_prog list; (* (* retrieval of metdata *) diff --git a/src/tools/scamv/persistence/embexp_logsLib.sml b/src/tools/scamv/persistence/embexp_logsLib.sml index 1499107fc..4fe82fa08 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sml +++ b/src/tools/scamv/persistence/embexp_logsLib.sml @@ -22,8 +22,11 @@ val embexp_logs_dir = val command = embexp_logs_dir ^ "/scripts/db-interface.py"; -fun run_db ops arg = - bir_json_execLib.call_json_exec (command, (if !is_testing then ["-t"] else [])@[ops], arg); +fun run_db_gen extra ops arg = + bir_json_execLib.call_json_exec (command, (if !is_testing then ["-t"] else [])@extra@[ops], arg); + +fun run_db ops arg = run_db_gen [] ops arg; +fun run_db_ro ops arg = run_db_gen ["-ro"] ops arg; val run_db_q = run_db "query"; fun run_db_q_gen id_only t vs = run_db_q ( @@ -40,6 +43,13 @@ fun get_db_q r = case r of OBJECT [("fields", ARRAY fs), ("rows", ARRAY xs)] => (fs, xs) | _ => raise Fail "scanned result does not match a query response"; +val run_db_q_ro = run_db_ro "query"; +fun run_db_q_sql sql_s = run_db_q_ro ( + OBJECT + [("type", STRING "sql"), + ("query", + OBJECT + [("sql", STRING sql_s)])]); val run_db_c = run_db "create"; fun run_db_c_map id_only do_match t vs = @@ -202,17 +212,24 @@ fun run_db_a_ignore t vs = (* *) (* TODO: change to not ignore the fields in the result *) - fun get_from_id (t, f_id) unpack_fun id = - case get_db_q (run_db_q_gen false t [(f_id, NUMBER id)]) of + fun from_q_res_unpack_sing unpack_fun r = + case r of (_, [x]) => (case x of ARRAY vals => unpack_fun vals - | _ => raise ERR "get_from_id" "result not as expected") - | _ => raise ERR "get_from_id" "result not as expected"; - fun get_from_id_mult (t, f_id) unpack_fun id = - case get_db_q (run_db_q_gen false t [(f_id, NUMBER id)]) of + | _ => raise ERR "from_q_res_unpack_sing" "result not as expected") + | _ => raise ERR "from_q_res_unpack_sing" "result not as expected"; + + fun from_q_res_unpack_mult unpack_fun r = + case r of (_, xs) => List.map (fn x => case x of ARRAY vals => unpack_fun vals - | _ => raise ERR "get_from_id_mult" "result not as expected") xs; + | _ => raise ERR "from_q_res_unpack_mult" "result not as expected") xs; + + fun get_from_id (t, f_id) unpack_fun id = + from_q_res_unpack_sing unpack_fun (get_db_q (run_db_q_gen false t [(f_id, NUMBER id)])); + + fun get_from_id_mult (t, f_id) unpack_fun id = + from_q_res_unpack_mult unpack_fun (get_db_q (run_db_q_gen false t [(f_id, NUMBER id)])); fun get_from_ids (t, f_id) unpack_fun ids = List.map (fn id => get_from_id (t, f_id) unpack_fun id) ids; @@ -296,19 +313,29 @@ fun run_db_a_ignore t vs = (* *) -val run_db_h = run_db "hack"; -fun run_db_h_gen tn = run_db_h ( - STRING tn); + fun unpack_logs_prog_widx x = + case x of + [NUMBER idx, NUMBER _, STRING a, STRING c] => + (Arbnum.toInt idx, LogsProg (a, c)) + | _ => raise ERR "unpack_logs_prog_widx" "result not as expected"; - fun get_hack_from_id_mult unpack_fun tn = - case get_db_q (run_db_h_gen tn) of - (_, xs) => List.map (fn x => case x of - ARRAY vals => unpack_fun vals - | _ => raise ERR "get_all_ids_mult" "result not as expected") xs; + fun unpack_logs_exp_widx x = + case x of + [NUMBER idx, NUMBER _, NUMBER p_id, STRING ty, STRING pa, STRING indat] => + (Arbnum.toInt idx, LogsExp (p_id, ty, pa, unpack_json indat)) + | _ => raise ERR "unpack_logs_exp_widx" "result not as expected"; + + fun sql_wholefromlist lstty listid = + "select tbl_1.list_index, tbl_0.* \n" ^ + "from exp_" ^ lstty ^ " as tbl_0 \n" ^ + "inner join exp_" ^ lstty ^ "_lists_entries as tbl_1 on tbl_0.id = tbl_1.exp_" ^ lstty ^ "_id \n" ^ + "where tbl_1.exp_" ^ lstty ^ "_lists_id = " ^ (Arbnum.toString listid); -fun hack_get_prog_list_by_listname listname = -get_hack_from_id_mult unpack_logs_prog listname; + fun get_prog_list_entries_full listid = + from_q_res_unpack_mult unpack_logs_prog_widx (get_db_q (run_db_q_sql (sql_wholefromlist "progs" listid))); + fun get_exp_list_entries_full listid = + from_q_res_unpack_mult unpack_logs_exp_widx (get_db_q (run_db_q_sql (sql_wholefromlist "exps" listid))); (* *) diff --git a/src/tools/scamv/persistence/persistenceLib.sml b/src/tools/scamv/persistence/persistenceLib.sml index ec885dc40..3ea9047ae 100644 --- a/src/tools/scamv/persistence/persistenceLib.sml +++ b/src/tools/scamv/persistence/persistenceLib.sml @@ -279,7 +279,6 @@ struct (* ========================================================================================= *) fun runlogs_load_progs listname = let - (* val prog_l_ids = query_all_prog_lists (); val prog_ls = get_prog_lists prog_l_ids; @@ -289,11 +288,7 @@ struct raise ERR "runlogs_load_progs" ("didn't find exactly one match for prog list " ^ listname); val prog_l_id = List.nth (prog_l_ids, i); - val prog_ids = List.map snd (get_prog_list_entries prog_l_id); - - val progs_i = get_progs prog_ids; - *) - val progs_i = hack_get_prog_list_by_listname listname; + val progs_i = List.map snd (get_prog_list_entries_full prog_l_id); val progs = List.map (fn (LogsProg (_,code)) => prog_from_asm_code code) progs_i; in From 78a600f04f70061f678fc2c8030f085e2474204d Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 5 Feb 2021 22:25:10 +0100 Subject: [PATCH 0005/1015] Quickfix for something that is different in k14 --- src/tools/scamv/examples/scripts/1-gen.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/scamv/examples/scripts/1-gen.sh b/src/tools/scamv/examples/scripts/1-gen.sh index 57a2077e8..83d441f10 100755 --- a/src/tools/scamv/examples/scripts/1-gen.sh +++ b/src/tools/scamv/examples/scripts/1-gen.sh @@ -44,6 +44,6 @@ SCAMV_HOLBA_RUN_DESCR="1-gen.sh_${EXPGENRUN_PREFIX_PARAM}_${EXPGENRUN_ID_PARAM}" # start experiment generation process cd "${SCAMV_EXAMPLES_DIR}" -./scamv.sh --run_description "${SCAMV_HOLBA_RUN_DESCR}" ${SCAMV_EXPGENRUN_PARAMS} +./scamv_buildheap.sh --run_description "${SCAMV_HOLBA_RUN_DESCR}" ${SCAMV_EXPGENRUN_PARAMS} From db59443b6be5317804b84841cfca48ff71fc7321 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 5 Feb 2021 23:47:15 +0100 Subject: [PATCH 0006/1015] Add general sql queries to the interface (read-only) --- src/tools/scamv/persistence/embexp_logsLib.sig | 4 +--- src/tools/scamv/persistence/embexp_logsLib.sml | 14 +++++++++++++- src/tools/scamv/persistence/t-test-logs.sml | 15 +++++++++++++++ 3 files changed, 29 insertions(+), 4 deletions(-) diff --git a/src/tools/scamv/persistence/embexp_logsLib.sig b/src/tools/scamv/persistence/embexp_logsLib.sig index a40a72e60..702c3c5e6 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sig +++ b/src/tools/scamv/persistence/embexp_logsLib.sig @@ -97,9 +97,7 @@ sig - ! it deliberately doesn't return handles so that links in the db cannot be messed up ! - the returned json values are of one of the following types: NULL, NUMBER, STRING *) -(* - val query_sql : string -> (string list * json.Json list list); -*) + val query_sql : string -> (string list * Json.json list list); (* function to enable the testing mode, i.e., uses the testing db *) val set_testing : unit -> unit; diff --git a/src/tools/scamv/persistence/embexp_logsLib.sml b/src/tools/scamv/persistence/embexp_logsLib.sml index 4fe82fa08..cf69069d5 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sml +++ b/src/tools/scamv/persistence/embexp_logsLib.sml @@ -381,7 +381,19 @@ fun run_db_a_ignore t vs = (* *) - + fun unpack_string x = + case x of + STRING x => x + | _ => raise ERR "unpack_string" "result not as expected"; + + fun query_sql sql_s = + let + val (j_fields, j_data) = get_db_q (run_db_q_sql sql_s); + val fields = List.map unpack_string j_fields; + val data = from_q_res_unpack_mult (fn x => x) (NONE, j_data); + in + (fields, data) + end; end (* local *) end (* struct *) diff --git a/src/tools/scamv/persistence/t-test-logs.sml b/src/tools/scamv/persistence/t-test-logs.sml index cffdb1c88..0560bfdf0 100644 --- a/src/tools/scamv/persistence/t-test-logs.sml +++ b/src/tools/scamv/persistence/t-test-logs.sml @@ -272,6 +272,21 @@ val prog_ids = List.map snd (get_prog_list_entries prog_l_id); val progs = get_progs prog_ids; +(* tests for raw sql query *) +val _ = + assert_w_descr + "cannot write with raw sql query" + (fn () => (query_sql "insert into db_meta (id, name, kind, value) values (NULL, \"123newww\", \"valuewextremenew\", \"a test\")"; false) + handle _ => true); + +val rawquery_res = query_sql "select code, id from exp_progs where id = 1"; +val rawquery_expected = (["code", "id"], [[STRING "\tpush all\n", NUMBER (Arbnum.fromInt 1)]]); +val _ = + assert_w_descr + "reading works as expected with raw sql query" + (fn () => (rawquery_res = rawquery_expected)); + + (* try persistenceLib directly *) open persistenceLib; From d9fc37b163cd9262f2e791055148f614c4afacb4 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 6 Feb 2021 01:01:43 +0100 Subject: [PATCH 0007/1015] Add metadata retrieval functions --- .../scamv/persistence/embexp_logsLib.sig | 8 +++- .../scamv/persistence/embexp_logsLib.sml | 34 ++++++++++++--- src/tools/scamv/persistence/t-test-logs.sml | 43 +++++++++++++++++++ 3 files changed, 77 insertions(+), 8 deletions(-) diff --git a/src/tools/scamv/persistence/embexp_logsLib.sig b/src/tools/scamv/persistence/embexp_logsLib.sig index 702c3c5e6..45594ef44 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sig +++ b/src/tools/scamv/persistence/embexp_logsLib.sig @@ -32,6 +32,10 @@ sig val mk_run_meta_handle : (run_handle * string option * string) -> meta_handle; val mk_prog_meta_handle : (prog_handle * string option * string) -> meta_handle; val mk_exp_meta_handle : (exp_handle * string option * string) -> meta_handle; + (* decompose metadata handles *) + val dest_run_meta_handle : meta_handle -> (run_handle * string option * string); + val dest_prog_meta_handle : meta_handle -> (prog_handle * string option * string); + val dest_exp_meta_handle : meta_handle -> (exp_handle * string option * string); (* creation of basic entries *) val create_prog_list : logs_list -> prog_list_handle; @@ -66,12 +70,11 @@ sig val get_prog_list_entries_full : prog_list_handle -> (int * logs_prog) list; val get_exp_list_entries_full : exp_list_handle -> (int * logs_exp ) list; -(* (* retrieval of metdata *) val get_run_metadata : run_handle -> logs_meta list; val get_prog_metadata : prog_handle -> logs_meta list; val get_exp_metadata : exp_handle -> logs_meta list; -*) + (* queries *) val query_all_prog_lists : unit -> prog_list_handle list; @@ -99,6 +102,7 @@ sig *) val query_sql : string -> (string list * Json.json list list); + (* function to enable the testing mode, i.e., uses the testing db *) val set_testing : unit -> unit; diff --git a/src/tools/scamv/persistence/embexp_logsLib.sml b/src/tools/scamv/persistence/embexp_logsLib.sml index cf69069d5..9df3a94b9 100644 --- a/src/tools/scamv/persistence/embexp_logsLib.sml +++ b/src/tools/scamv/persistence/embexp_logsLib.sml @@ -129,6 +129,12 @@ fun run_db_a_ignore t vs = fun mk_prog_meta_handle (prog_id, k_o, n) = (MetaTypeProg, (prog_id, k_o, n)); fun mk_exp_meta_handle (exp_id , k_o, n) = (MetaTypeExp, (exp_id, k_o, n)); + fun dest_run_meta_handle (MetaTypeRun, (run_id, k_o, n)) = (run_id , k_o, n) + | dest_run_meta_handle _ = raise ERR "dest_run_meta_handle" "wrong handle type"; + fun dest_prog_meta_handle (MetaTypeProg, (prog_id, k_o, n)) = (prog_id, k_o, n) + | dest_prog_meta_handle _ = raise ERR "dest_prog_meta_handle" "wrong handle type"; + fun dest_exp_meta_handle (MetaTypeExp, (exp_id, k_o, n)) = (exp_id , k_o, n) + | dest_exp_meta_handle _ = raise ERR "dest_exp_meta_handle" "wrong handle type"; (* *) @@ -339,12 +345,28 @@ fun run_db_a_ignore t vs = (* *) -(* - (* retrieval of metdata *) - val get_run_metadata : run_handle -> logs_meta list; - val get_prog_metadata : prog_handle -> logs_meta list; - val get_exp_metadata : exp_handle -> logs_meta list; -*) + fun unpack_logs_meta mt x = + case x of + [NUMBER id, j_kind, STRING name, j_value] => + LogsMeta ((mt, (id, unpack_string_opt j_kind, name)) + ,unpack_string_opt j_value) + | _ => raise ERR "unpack_logs_meta" "result not as expected"; + + fun get_run_metadata id = + get_from_id_mult + ("holba_runs_meta", "holba_runs_id") + (unpack_logs_meta MetaTypeRun) + id; + fun get_prog_metadata id = + get_from_id_mult + ("exp_progs_meta", "exp_progs_id") + (unpack_logs_meta MetaTypeProg) + id; + fun get_exp_metadata id = + get_from_id_mult + ("exp_exps_meta", "exp_exps_id") + (unpack_logs_meta MetaTypeExp) + id; diff --git a/src/tools/scamv/persistence/t-test-logs.sml b/src/tools/scamv/persistence/t-test-logs.sml index 0560bfdf0..264a111c5 100644 --- a/src/tools/scamv/persistence/t-test-logs.sml +++ b/src/tools/scamv/persistence/t-test-logs.sml @@ -287,6 +287,49 @@ val _ = (fn () => (rawquery_res = rawquery_expected)); +(* tests for metadata retrieval *) +val meta_ret_entry_1 = + let + val LogsMeta (mh, vo) = List.nth(get_run_metadata holba_run_1, 3); + val (a,b,c) = dest_run_meta_handle mh; + in + (a,b,c,vo) + end; +val meta_ret_entry_1_expected = (holba_run_1, SOME "ahaa", "meta null 1", NONE); +val _ = + assert_w_descr + "retrieving metadata - run" + (fn () => (meta_ret_entry_1 = meta_ret_entry_1_expected)); + +val meta_ret_entry_2 = + let + val LogsMeta (mh, vo) = List.nth(get_prog_metadata prog_1, 0); + val (a,b,c) = dest_prog_meta_handle mh; + in + (a,b,c,vo) + end; +val meta_ret_entry_2_expected = (prog_1, SOME "all", "prog meta 1", + SOME "very important\nvery important add\nvery important add\n"); +val _ = + assert_w_descr + "retrieving metadata - prog" + (fn () => (meta_ret_entry_2 = meta_ret_entry_2_expected)); + +val meta_ret_entry_3 = + let + val LogsMeta (mh, vo) = List.nth(get_exp_metadata exp_1, 0); + val (a,b,c) = dest_exp_meta_handle mh; + in + (a,b,c,vo) + end; +val meta_ret_entry_3_expected = (exp_1, SOME "all", "exp meta 1", + SOME "very important\nvery important add\n"); +val _ = + assert_w_descr + "retrieving metadata - exp" + (fn () => (meta_ret_entry_3 = meta_ret_entry_3_expected)); + + (* try persistenceLib directly *) open persistenceLib; From 2b12b1f1c6adcbf8e367f46a325c11c8c1d322ed Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Sat, 6 Feb 2021 01:24:46 +0100 Subject: [PATCH 0008/1015] Add command line switch for concrete execution (default is off) --- src/tools/scamv/bir_scamv_driverLib.sml | 12 +++-- src/tools/scamv/scamv_configLib.sml | 67 +++++++++++++++++++------ 2 files changed, 60 insertions(+), 19 deletions(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index eae4a34f8..28fb0c126 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -88,6 +88,7 @@ fun print_model model = val hw_obs_model_id = ref ""; val do_enum = ref false; val do_training = ref false; +val do_conc_exec = ref false; val (current_prog_id : embexp_logsLib.prog_handle option ref) = ref NONE; val (current_prog : term option ref) = ref NONE; @@ -359,9 +360,12 @@ fun next_experiment all_exps next_relation = SOME x => x | NONE => raise ERR "next_test" "no program found"; - val ce_obs_comp = conc_exec_obs_compare (!current_obs_projection) lifted_prog_w_obs (s1, s2) - val _ = if ce_obs_comp then () else + val _ = if not (!do_conc_exec) then () else ( + let + val ce_obs_comp = conc_exec_obs_compare (!current_obs_projection) lifted_prog_w_obs (s1, s2); + val _ = if ce_obs_comp then () else raise ERR "next_experiment" "Experiment does not yield equal observations, won't generate an experiment."; + in () end); (* show time *) val d_s = Time.- (Time.now(), timer) |> Time.toString; @@ -478,7 +482,7 @@ fun scamv_run { max_iter = m, prog_size = sz, max_tests = tests, enumerate = enu , obs_model = obs_model, hw_obs_model = hw_obs_model , refined_obs_model = refined_obs_model, obs_projection = proj , verbosity = verb, seed_rand = seed_rand, do_training = train - , run_description = descr_o } = + , run_description = descr_o, exec_conc = doexecconc } = let val _ = bir_randLib.rand_isfresh_set seed_rand; @@ -487,6 +491,7 @@ fun scamv_run { max_iter = m, prog_size = sz, max_tests = tests, enumerate = enu val _ = do_enum := enumerate; val _ = do_training := train; + val _ = do_conc_exec := doexecconc; val _ = current_obs_projection := proj; val prog_store_fun = @@ -511,6 +516,7 @@ fun scamv_run { max_iter = m, prog_size = sz, max_tests = tests, enumerate = enu ("HW observation model : " ^ !hw_obs_model_id ^ "\n") ^ ("Enumerate : " ^ PolyML.makestring (!do_enum) ^ "\n") ^ ("Train branch pred. : " ^ PolyML.makestring (!do_training) ^ "\n") ^ + ("Execute concretely : " ^ PolyML.makestring (!do_conc_exec) ^ "\n") ^ ("Run description text : " ^ PolyML.makestring descr_o ^ "\n") ; val _ = run_log config_str; diff --git a/src/tools/scamv/scamv_configLib.sml b/src/tools/scamv/scamv_configLib.sml index f71357504..e3be460a9 100644 --- a/src/tools/scamv/scamv_configLib.sml +++ b/src/tools/scamv/scamv_configLib.sml @@ -46,7 +46,8 @@ type scamv_config = { max_iter : int, verbosity : int, seed_rand : bool, do_training : bool, - run_description : string option + run_description : string option, + exec_conc : bool } val default_cfg = { max_iter = 10 @@ -63,6 +64,7 @@ val default_cfg = { max_iter = 10 , seed_rand = true , do_training = false , run_description = NONE + , exec_conc = false } fun gen_type_fromString gt = @@ -111,7 +113,8 @@ fun set_max_iter (cfg : scamv_config) n = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_prog_size (cfg : scamv_config) n = { max_iter = # max_iter cfg, @@ -127,7 +130,8 @@ fun set_prog_size (cfg : scamv_config) n = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_max_tests (cfg : scamv_config) n = { max_iter = # max_iter cfg, @@ -143,7 +147,8 @@ fun set_max_tests (cfg : scamv_config) n = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_enumerate (cfg : scamv_config) enum = { max_iter = # max_iter cfg, @@ -159,7 +164,8 @@ fun set_enumerate (cfg : scamv_config) enum = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_generator (cfg : scamv_config) gen = { max_iter = # max_iter cfg, @@ -175,7 +181,8 @@ fun set_generator (cfg : scamv_config) gen = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_generator_param (cfg : scamv_config) gen_param = { max_iter = # max_iter cfg, @@ -191,7 +198,8 @@ fun set_generator_param (cfg : scamv_config) gen_param = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_obs_model (cfg : scamv_config) om = { max_iter = # max_iter cfg, @@ -207,7 +215,8 @@ fun set_obs_model (cfg : scamv_config) om = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_refined_obs_model (cfg : scamv_config) om = { max_iter = # max_iter cfg, @@ -223,7 +232,8 @@ fun set_refined_obs_model (cfg : scamv_config) om = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_obs_projection (cfg : scamv_config) obs_number = @@ -240,7 +250,8 @@ fun set_obs_projection (cfg : scamv_config) obs_number = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_hw_obs_model (cfg : scamv_config) hwom = @@ -257,7 +268,8 @@ fun set_hw_obs_model (cfg : scamv_config) hwom = verbosity = # verbosity cfg, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_verbosity (cfg : scamv_config) v = { max_iter = # max_iter cfg, @@ -273,7 +285,8 @@ fun set_verbosity (cfg : scamv_config) v = verbosity = v, seed_rand = # seed_rand cfg, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_seed_rand (cfg : scamv_config) s = { max_iter = # max_iter cfg, @@ -289,7 +302,8 @@ fun set_seed_rand (cfg : scamv_config) s = verbosity = # verbosity cfg, seed_rand = s, do_training = # do_training cfg, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_do_training (cfg : scamv_config) s = { max_iter = # max_iter cfg, @@ -305,7 +319,8 @@ fun set_do_training (cfg : scamv_config) s = verbosity = # verbosity cfg, seed_rand = #seed_rand cfg, do_training = s, - run_description = # run_description cfg }; + run_description = # run_description cfg, + exec_conc = # exec_conc cfg }; fun set_run_description (cfg : scamv_config) s = { max_iter = # max_iter cfg, @@ -321,7 +336,25 @@ fun set_run_description (cfg : scamv_config) s = verbosity = # verbosity cfg, seed_rand = #seed_rand cfg, do_training = # do_training cfg, - run_description = s }; + run_description = s, + exec_conc = # exec_conc cfg }; + +fun set_exec_conc (cfg : scamv_config) s = + { max_iter = # max_iter cfg, + prog_size = # prog_size cfg, + max_tests = # max_tests cfg, + enumerate = # enumerate cfg, + generator = # generator cfg, + generator_param = # generator_param cfg, + obs_model = # obs_model cfg, + refined_obs_model = # refined_obs_model cfg, + obs_projection = # obs_projection cfg, + hw_obs_model = # hw_obs_model cfg, + verbosity = # verbosity cfg, + seed_rand = #seed_rand cfg, + do_training = # do_training cfg, + run_description = # run_description cfg, + exec_conc = s }; (* end boilerplate *) @@ -355,12 +388,14 @@ val opt_table = handle_conv_arg_with Int.fromString set_obs_projection) , Arity1 ("hwom", "hw_obs_model", "HW observation model", handle_conv_arg_with hw_obs_model_fromString set_hw_obs_model) - , Arity0 ("frs", "fix_rand_seed", "Fix the seed for the random number generators.", + , Arity0 ("frs", "fix_rand_seed", "Fix the seed for the random number generators (for debugging and testing).", fn cfg => fn b => set_seed_rand cfg (not b)) , Arity0 ("T", "training", "Train branch predictor (only works if observing PC)", fn cfg => fn b => set_do_training cfg b) , Arity1 ("rundes", "run_description", "Run description text", handle_conv_arg_with (fn x => SOME (SOME x)) set_run_description) + , Arity0 ("ec", "exec_conc", "Execute generated states to validate obs eq", + fn cfg => fn b => set_exec_conc cfg b) ]; end From 84bb3ddc54d5d631d971862c194027db8db15e07 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 9 Feb 2021 01:03:46 +0100 Subject: [PATCH 0009/1015] Add boolean lessthanequal to bir-smt exporter --- src/shared/bir_smtLib.sml | 8 +++++++- src/shared/examples/test-smtLib.sml | 6 +++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src/shared/bir_smtLib.sml b/src/shared/bir_smtLib.sml index d3633fc68..a3d1fac8e 100644 --- a/src/shared/bir_smtLib.sml +++ b/src/shared/bir_smtLib.sml @@ -256,17 +256,23 @@ in val sty = get_smtlib_type_args probfun args; fun gen_exp opstr = gen_smtlib_expr opstr args SMTTY_Bool; in + (* simple equality *) (* TODO: BinPred cannot be applied to memories! *) if is_BIExp_Equal bpredop then gen_exp "=" else if is_BIExp_NotEqual bpredop then apply_smtlib_op (fn s => "(not " ^ s ^ ")") (gen_exp "=") - (* TODO: BinPred can be applied to Imm1! *) + (* bitvectors *) else if smt_type_is_bv sty then if is_BIExp_LessThan bpredop then gen_exp "bvult" else if is_BIExp_SignedLessThan bpredop then gen_exp "bvslt" else if is_BIExp_LessOrEqual bpredop then gen_exp "bvule" else if is_BIExp_SignedLessOrEqual bpredop then gen_exp "bvsle" else problem_gen_sty "bpredop_to_smtlib" bpredop sty + (* bools *) + (* TODO: BinPred can be applied to Imm1, handle remaining cases here! *) + else if smt_type_is_bool sty then + if is_BIExp_LessOrEqual bpredop then gen_exp "=>" + else problem_gen_sty "bpredop_to_smtlib" bpredop sty else problem_gen_sty "bpredop_to_smtlib" bpredop sty end; diff --git a/src/shared/examples/test-smtLib.sml b/src/shared/examples/test-smtLib.sml index dc0586f0b..5b7215965 100644 --- a/src/shared/examples/test-smtLib.sml +++ b/src/shared/examples/test-smtLib.sml @@ -67,7 +67,11 @@ val exporting_exp_testcases = [ (``BExp_Cast BIExp_HighCast (BExp_Const (Imm16 0x4480w)) Bit8``, ("((_ extract 15 8) (_ bv17536 16))", SMTTY_BV 8)), (``BExp_Cast BIExp_HighCast (BExp_Const (Imm8 0x80w)) Bit16``, - ("(concat #b00000000 (_ bv128 8))", SMTTY_BV 16)) + ("(concat #b00000000 (_ bv128 8))", SMTTY_BV 16)), + + + (``BExp_BinPred BIExp_LessOrEqual (BExp_Const (Imm1 0x1w)) (BExp_Const (Imm1 0x0w))``, + ("(=> true false)", SMTTY_Bool)) ]; (* From 041af31ce306a1fcfac2691c42a84910cf7ad40a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 16 Feb 2021 21:46:30 +0100 Subject: [PATCH 0010/1015] Factor out term printer with types --- src/tools/scamv/persistence/experimentsLib.sig | 2 ++ src/tools/scamv/persistence/experimentsLib.sml | 9 +++++++++ src/tools/scamv/proggen/bir_prog_genLib.sml | 7 ------- 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/tools/scamv/persistence/experimentsLib.sig b/src/tools/scamv/persistence/experimentsLib.sig index 6f0c44f16..e079c4ba9 100644 --- a/src/tools/scamv/persistence/experimentsLib.sig +++ b/src/tools/scamv/persistence/experimentsLib.sig @@ -1,5 +1,7 @@ signature experimentsLib = sig + val term_to_string_wtypes : Abbrev.term -> string; + (* machine states *) (* ======================================== *) (* a machine consists of register to value mappings and a memory mapping *) diff --git a/src/tools/scamv/persistence/experimentsLib.sml b/src/tools/scamv/persistence/experimentsLib.sml index 8f45a46a3..3f7687d44 100644 --- a/src/tools/scamv/persistence/experimentsLib.sml +++ b/src/tools/scamv/persistence/experimentsLib.sml @@ -11,6 +11,15 @@ local val wrap_exn = Feedback.wrap_exn libname in + (* TODO: put this in a more general HolBA place... *) + fun term_to_string_wtypes t = + let + val trace_val = Feedback.get_tracefn "types" (); + val _ = Feedback.set_trace "types" 1; + val s = term_to_string t; + val _ = Feedback.set_trace "types" trace_val; + in s end; + (* machine states *) (* ======================================== *) (* machine state definition from the signature *) diff --git a/src/tools/scamv/proggen/bir_prog_genLib.sml b/src/tools/scamv/proggen/bir_prog_genLib.sml index c9e3f8535..53bfbfeec 100644 --- a/src/tools/scamv/proggen/bir_prog_genLib.sml +++ b/src/tools/scamv/proggen/bir_prog_genLib.sml @@ -148,13 +148,6 @@ struct val prog_with_halt = add_halt_to_prog len lifted_prog; val add_lifted_prog = true; - fun term_to_string_wtypes t = - let - val trace_val = Feedback.get_tracefn "types" (); - val _ = Feedback.set_trace "types" 1; - val s = term_to_string t; - val _ = Feedback.set_trace "types" trace_val; - in s end; val extra_metadata = if not add_lifted_prog then [] else [("lifted_prog", term_to_string_wtypes lifted_prog)]; From 7799a8e8e6eb9a99a0962b1211585f873ca5462d Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 16 Feb 2021 21:47:19 +0100 Subject: [PATCH 0011/1015] Add flag in code to enable printing of types when printing the word relation --- src/tools/scamv/bir_scamv_driverLib.sml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index 28fb0c126..07d64fb27 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -288,8 +288,10 @@ fun next_experiment all_exps next_relation = bir_exp_pretty_print rel); val _ = printv 4 ("Word relation\n"); val new_word_relation = make_word_relation rel true; + val print_word_rel_wtypes = false; + val term_to_string_sel = if print_word_rel_wtypes then term_to_string_wtypes else term_to_string; val _ = min_verb 4 (fn () => - (print_term new_word_relation; + (print (term_to_string_sel new_word_relation); print "\n")); (* val word_relation = case !current_word_rel of From cbff32791562f1e27eb972f79c5818ae130baf57 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 00:05:54 +0100 Subject: [PATCH 0012/1015] Add testing for whole chain: bir expression through HolSmt/z3 to word model (indirect testing of HolSmt) --- .../test-bir-to-word-to-z3-sat-model.sml | 108 ++++++++++++++++++ 1 file changed, 108 insertions(+) create mode 100644 src/shared/examples/test-bir-to-word-to-z3-sat-model.sml diff --git a/src/shared/examples/test-bir-to-word-to-z3-sat-model.sml b/src/shared/examples/test-bir-to-word-to-z3-sat-model.sml new file mode 100644 index 000000000..45b7912c4 --- /dev/null +++ b/src/shared/examples/test-bir-to-word-to-z3-sat-model.sml @@ -0,0 +1,108 @@ +open HolKernel Parse boolLib bossLib; + +open bir_exp_to_wordsLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = wordsLib.add_word_cast_printer (); +val _ = Globals.show_types := true; + +(* +(* for debugging the z3 input and output (keep the temporary files) *) +val _ = Library.trace := 5; +*) + +val bir_exprs = [ + ("32-bits constant, plus, eq, novar, sat", + ``BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_Plus (BExp_Const (Imm32 12345w)) (BExp_Const (Imm32 1w))) + (BExp_Const (Imm32 12346w))``, + NONE, + SOME true), + ("32-bits constant, plus, eq, sat", + ``BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_Plus (BExp_Const (Imm32 12345w)) (BExp_Const (Imm32 x))) + (BExp_Const (Imm32 12346w))``, + SOME [("x", “(1w :word32)”)], + SOME true), + ("32-bits constant, plus, eq, unsat", + ``BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_Minus (BExp_Const (Imm32 12345w)) (BExp_Const (Imm32 1w))) + (BExp_Const (Imm32 12346w))``, + NONE, + SOME false), + ("32-bits constant, right shift, eq, novar, sat", + ``BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_RightShift (BExp_Const (Imm32 0xFFw)) (BExp_Const (Imm32 2w))) + (BExp_Const (Imm32 x))``, + SOME [("x", “(0x3Fw :word32)”)], + SOME true), + ("32-bits constant, left shift, eq, novar, sat", + ``BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_LeftShift (BExp_Const (Imm32 0xFFw)) (BExp_Const (Imm32 2w))) + (BExp_Const (Imm32 x))``, + SOME [("x", “(0x3FCw :word32)”)], + SOME true), + ("32-bits constant, unsigned cast up, eq, novar, sat", + ``BExp_BinPred BIExp_Equal + (BExp_Cast BIExp_UnsignedCast (BExp_Const (Imm32 0xFFw)) Bit64) + (BExp_Const (Imm64 x))``, + SOME [("x", “(0xFFw :word64)”)], + SOME true), + ("32-bits constant, unsigned cast down, eq, novar, sat", + ``BExp_BinPred BIExp_Equal + (BExp_Cast BIExp_UnsignedCast (BExp_Const (Imm32 0xFFFFw)) Bit8) + (BExp_Const (Imm8 x))``, + SOME [("x", “(0xFFw :word8)”)], + SOME true) +]; + +fun produce_sat_thm term model = + let + val eq_list = List.map (fn (name, tm) => Term [QUOTE name, QUOTE " = ", ANTIQUOTE tm]) model; + val conj_assign_tm = list_mk_conj eq_list; + val imp_tm = mk_imp (conj_assign_tm, term); + in + prove (imp_tm, SIMP_TAC std_ss [] >> EVAL_TAC) + end; + +val model_eq = option_eq (list_eq (pair_eq (fn (a:string) => fn (b:string) => a=b) identical)); + +(* +val (name, bir_exp, expected_model_o, expected_sat_o) = List.nth(bir_exprs, 2); +*) + +(* Print all BIR expressions as words expressions and check that they are correct. *) +val _ = List.map + (fn (name, bir_exp, expected_model_o, expected_sat_o) => + let + val word_exp_bool = bir2bool bir_exp; + + val model_o = + SOME (Z3_SAT_modelLib.Z3_GET_SAT_MODEL word_exp_bool) + handle _ => NONE; + + val sat_o = + case (model_o, expected_sat_o) of + (SOME model, SOME _) => + (SOME (produce_sat_thm word_exp_bool model; true) + handle _ => SOME false) + | (NONE, SOME _) => + (SOME (produce_sat_thm word_exp_bool [("aaaanooovaaarname", “T”)]; true) + handle _ => SOME false) + | _ => NONE; + + val correct = + model_eq expected_model_o model_o andalso + expected_sat_o = sat_o; + + val _ = print (name ^ ":\n") + val _ = Hol_pp.print_term word_exp_bool; + val _ = if correct then () else ( + print "Expected: \n"; + (*Hol_pp.print_term expected;*) + print "\n"; + raise Fail ("Incorrect result for '" ^ name ^ "'") + ) + val _ = print "\n" + in () end) bir_exprs; + From b3f6eeafa2511f596e3c34e5df448d26cb290028 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 14:20:00 +0100 Subject: [PATCH 0013/1015] Add scamv command line switch to manipulate the hol4 library trace level --- src/tools/scamv/scamv_configLib.sml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/tools/scamv/scamv_configLib.sml b/src/tools/scamv/scamv_configLib.sml index e3be460a9..b2a1f69fc 100644 --- a/src/tools/scamv/scamv_configLib.sml +++ b/src/tools/scamv/scamv_configLib.sml @@ -356,6 +356,9 @@ fun set_exec_conc (cfg : scamv_config) s = run_description = # run_description cfg, exec_conc = s }; +fun set_h4ltl (cfg : scamv_config) s = + (Library.trace := s; cfg); + (* end boilerplate *) local @@ -396,6 +399,8 @@ val opt_table = handle_conv_arg_with (fn x => SOME (SOME x)) set_run_description) , Arity0 ("ec", "exec_conc", "Execute generated states to validate obs eq", fn cfg => fn b => set_exec_conc cfg b) + , Arity1 ("h4ltl", "hol4_library_trace_level", "Set hol4 library trace level (e.g., 5 to let HolSmt keep temporary files with z3)", + handle_conv_arg_with Int.fromString set_h4ltl) ]; end From 699e440ed65280e44bba9bb7597e7358bdcb5ce5 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 18:18:50 +0100 Subject: [PATCH 0014/1015] Fix --- src/tools/scamv/scamv_configLib.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/scamv/scamv_configLib.sml b/src/tools/scamv/scamv_configLib.sml index b2a1f69fc..7e91bdb01 100644 --- a/src/tools/scamv/scamv_configLib.sml +++ b/src/tools/scamv/scamv_configLib.sml @@ -399,7 +399,7 @@ val opt_table = handle_conv_arg_with (fn x => SOME (SOME x)) set_run_description) , Arity0 ("ec", "exec_conc", "Execute generated states to validate obs eq", fn cfg => fn b => set_exec_conc cfg b) - , Arity1 ("h4ltl", "hol4_library_trace_level", "Set hol4 library trace level (e.g., 5 to let HolSmt keep temporary files with z3)", + , Arity1 ("h4ltl", "hol4_library_trace_level", "Set hol4 library trace level (e.g., 4 to let HolSmt keep temporary files with z3)", handle_conv_arg_with Int.fromString set_h4ltl) ]; end From 2def1585699f947a1a6b774e10b4a6ca55789ae1 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 18:20:34 +0100 Subject: [PATCH 0015/1015] Add debug print for intermediate simplification of HolSmt --- src/shared/Z3_SAT_modelLib.sml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/shared/Z3_SAT_modelLib.sml b/src/shared/Z3_SAT_modelLib.sml index a8817ba83..a374ec7d6 100644 --- a/src/shared/Z3_SAT_modelLib.sml +++ b/src/shared/Z3_SAT_modelLib.sml @@ -167,6 +167,19 @@ struct val ERR = ERR "Z3_GET_SAT_MODEL" val goal = ([], term) val (simplified_goal, _) = SolverSpec.simplify (SmtLib.SIMP_TAC false) goal + + val _ = + if !Library.trace > 4 then + let + val _ = print "simplified goal >>>\n"; + open HolKernel boolLib liteLib simpLib Parse bossLib; + val (sg_tl, sg_t) = simplified_goal; + val _ = print ((Int.toString (List.length sg_tl)) ^ "\n"); + val _ = print_term sg_t; + val _ = List.map print_term sg_tl; + val _ = print "<<< simplified goal done\n"; + in () end else (); + val result = Z3_ORACLE_SOLVE_GOAL simplified_goal in case result of From 4c959400cf64bd0c9ac8bb307862b76c71681c8f Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 18:21:10 +0100 Subject: [PATCH 0016/1015] Add example script to investigate/inspect HolSmt --- .../example-HolSmt-simplification.sml | 127 ++++++++++++++++++ 1 file changed, 127 insertions(+) create mode 100644 src/shared/examples/example-HolSmt-simplification.sml diff --git a/src/shared/examples/example-HolSmt-simplification.sml b/src/shared/examples/example-HolSmt-simplification.sml new file mode 100644 index 000000000..10d41d1ca --- /dev/null +++ b/src/shared/examples/example-HolSmt-simplification.sml @@ -0,0 +1,127 @@ +open HolKernel Parse boolLib bossLib; + + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = wordsLib.add_word_cast_printer (); +val _ = Globals.show_types := true; + +(* +(* for debugging the z3 input and output (keep the temporary files) *) +val _ = Library.trace := 5; +*) + +val mem1_var = mk_var ("MEM", “:word64 |-> word8”); +val mem2_var = mk_var ("MEM", “:word64 |-> word8”); + +val term = “ +(w2w (w2w (^mem1_var ' R1) :word64):word1) += +w2w (^mem2_var ' R2)”; + +(* +val term = “ +((((if + (0x80100000w :word64) ≤₊ + (R26 :word64) + + (w2w + (w2w + (w2w + (((^mem1_var :word64 |-> word8) ' + ((R28 :word64) + (12w :word64) + (0w :word64))) + :word8) :word64) :word32) :word64) <<~ (3w :word64) ∧ + R26 + + (w2w + (w2w + (w2w ((^mem1_var ' (R28 + (12w :word64) + (0w :word64))) :word8) : + word64) :word32) :word64) <<~ (3w :word64) <₊ (0x8013FF80w + :word64) + then + (1w :word1) + else (0w :word1)) && + (if + R26 + + (w2w + (w2w + (w2w ((^mem1_var ' (R28 + (12w :word64) + (0w :word64))) :word8) : + word64) :word32) :word64) <<~ (3w :word64) && (7w :word64) = + (0w + :word64) + then + (1w :word1) + else (0w :word1)) && + (if (0x80100000w :word64) ≤₊ R28 ∧ R28 <₊ (0x8013FF80w :word64) then + (1w :word1) + else (0w :word1)) && (1w :word1)) && + ((if + (0x80100000w :word64) ≤₊ + (R26' :word64) + + (w2w + (w2w + (w2w + (((^mem2_var :word64 |-> word8) ' + ((R28' :word64) + (12w :word64) + (0w :word64))) + :word8) :word64) :word32) :word64) <<~ (3w :word64) ∧ + R26' + + (w2w + (w2w + (w2w ((^mem2_var ' (R28' + (12w :word64) + (0w :word64))) :word8) : + word64) :word32) :word64) <<~ (3w :word64) <₊ (0x8013FF80w + :word64) + then + (1w :word1) + else (0w :word1)) && + (if + R26' + + (w2w + (w2w + (w2w ((^mem2_var ' (R28' + (12w :word64) + (0w :word64))) :word8) : + word64) :word32) :word64) <<~ (3w :word64) && (7w :word64) = + (0w + :word64) + then + (1w :word1) + else (0w :word1)) && + (if (0x80100000w :word64) ≤₊ R28' ∧ R28' <₊ (0x8013FF80w :word64) then + (1w :word1) + else (0w :word1)) && (1w :word1)) && ((1w :word1) && (1w :word1)) && + ((1w :word1) && (1w :word1)) && + (if + R28 >>>~ (6w :word64) = R28' >>>~ (6w :word64) ∧ + (R26 + + (w2w + (w2w + (w2w ((^mem1_var ' (R28 + (12w :word64) + (0w :word64))) :word8) : + word64) :word32) :word64) <<~ (3w :word64)) >>>~ (6w :word64) = + (R26' + + (w2w + (w2w + (w2w ((^mem2_var ' (R28' + (12w :word64) + (0w :word64))) :word8) : + word64) :word32) :word64) <<~ (3w :word64)) >>>~ (6w :word64) + then + (1w :word1) + else (0w :word1)) && ¬(0w :word1)) && (1w :word1)) && (1w :word1) = +(1w + :word1) ∧ (R26 ≠ R26' ∨ R28 ≠ R28') +”; +*) + + val goal = ([], term) + val (simplified_goal, _) = SolverSpec.simplify (SmtLib.SIMP_TAC false) goal + + open HolKernel boolLib liteLib simpLib Parse bossLib; + val (sg_tl, sg_t) = simplified_goal; + val _ = print ((Int.toString (List.length sg_tl)) ^ "\n"); + val _ = print_term sg_t; + val _ = List.map print_term sg_tl; + +(* +type_of term + + val goal = ([]:term list, “^term”) +(Library.WORD_SIMP_TAC) + goal +*) + +(* +Z3_SAT_modelLib.Z3_GET_SAT_MODEL term +*) From 7d01fa9042bc881592fdb47eaa496529a9a5335f Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 18:27:04 +0100 Subject: [PATCH 0017/1015] Fix naming --- src/tools/scamv/scamv_configLib.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tools/scamv/scamv_configLib.sml b/src/tools/scamv/scamv_configLib.sml index 7e91bdb01..2bf51cf6d 100644 --- a/src/tools/scamv/scamv_configLib.sml +++ b/src/tools/scamv/scamv_configLib.sml @@ -356,7 +356,7 @@ fun set_exec_conc (cfg : scamv_config) s = run_description = # run_description cfg, exec_conc = s }; -fun set_h4ltl (cfg : scamv_config) s = +fun set_hsmtltl (cfg : scamv_config) s = (Library.trace := s; cfg); (* end boilerplate *) @@ -399,8 +399,8 @@ val opt_table = handle_conv_arg_with (fn x => SOME (SOME x)) set_run_description) , Arity0 ("ec", "exec_conc", "Execute generated states to validate obs eq", fn cfg => fn b => set_exec_conc cfg b) - , Arity1 ("h4ltl", "hol4_library_trace_level", "Set hol4 library trace level (e.g., 4 to let HolSmt keep temporary files with z3)", - handle_conv_arg_with Int.fromString set_h4ltl) + , Arity1 ("hsmtltl", "holsmt_library_trace_level", "Set HolSmt library trace level (e.g., 4 to keep z3 temporary exchange files)", + handle_conv_arg_with Int.fromString set_hsmtltl) ]; end From a568e31954702582f5e3952dfa4bcf416ef62f7d Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 19:33:02 +0100 Subject: [PATCH 0018/1015] Less statefulness (no effect) --- src/shared/HolSmt/Library.sml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/shared/HolSmt/Library.sml b/src/shared/HolSmt/Library.sml index fa41adf7c..0cd67c8e9 100644 --- a/src/shared/HolSmt/Library.sml +++ b/src/shared/HolSmt/Library.sml @@ -278,14 +278,14 @@ struct (* A tactic that simplifies certain word expressions. *) - val TO_WORD_EXTRACT = Q.prove( - `(!w : 'a word. + val TO_WORD_EXTRACT = Tactical.prove( + ``(!w : 'a word. dimindex(:'b) < dimindex(:'a) ==> (w2w w : 'b word = (dimindex(:'b) - 1 >< 0) w)) /\ (!w : 'a word. dimindex(:'b) < dimindex(:'a) ==> - (sw2sw w : 'b word = (dimindex(:'b) - 1 >< 0) w))`, - BasicProvers.SRW_TAC [wordsLib.WORD_BIT_EQ_ss] []) + (sw2sw w : 'b word = (dimindex(:'b) - 1 >< 0) w))``, + BasicProvers.RW_TAC (bossLib.++ (bossLib.arith_ss, wordsLib.WORD_BIT_EQ_ss)) []); val WORD_BIT_EXTRACT = simpLib.SIMP_PROVE (simpLib.++(bossLib.std_ss, wordsLib.WORD_BIT_EQ_ss)) From 997adfe63316839bd102ef3cebd62d00bc3fe74f Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 17 Feb 2021 20:18:37 +0100 Subject: [PATCH 0019/1015] Fix for issue with HolSmt and variable naming --- src/tools/scamv/bir_scamv_driverLib.sml | 48 ++++++++++++++++++++++++- 1 file changed, 47 insertions(+), 1 deletion(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index 07d64fb27..44ffb05ef 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -205,6 +205,52 @@ fun scamv_phase_symb_exec () = ps end; +fun scamv_get_model word_relation = + let +(* +val mem1_var = mk_var ("MEM", “:word64 |-> word8”); +val mem2_var = mk_var ("MEM'", “:word64 |-> word8”); + +val word_relation = “ +(w2w (w2w (^mem1_var ' R1) :word64):word1) += +w2w (^mem2_var ' R2)”; + +to_new_name "MEM" +to_new_name "MEM'" +val t = hd vars +*) + fun to_new_name n = + "sv_" ^ (if String.isSuffix "'" n then (String.substring(n, 0, (String.size n)-1) ^ "_p") else n); + fun to_final_name n = + if String.isSuffix "'" n then (String.substring(n, 0, (String.size n)-1) ^ "_") else n; + fun var_to_new t = + let + val (vn, vt) = dest_var t; + in + (t, mk_var (to_new_name vn, vt)) + end; + fun rev_model_name rev_maplist (n_new, v) = + let + val m_o = List.find (fn (_, x) => x = n_new) rev_maplist; + val n = case m_o of + SOME (n,_) => n + | NONE => raise ERR "scamv_get_model" "unexpected error"; + in + (to_final_name n, v) + end; + + val vars = free_vars word_relation; + val vars_to_new = List.map var_to_new vars; + val varnames_to_new = List.map (fn (a,b) => ((fst o dest_var) a, (fst o dest_var) b)) vars_to_new; + + val word_relation_newnames = subst (List.map (|->) vars_to_new) word_relation; + val model_newnames = Z3_SAT_modelLib.Z3_GET_SAT_MODEL word_relation_newnames; + val model = List.map (rev_model_name varnames_to_new) model_newnames; + in + model + end; + fun scamv_phase_rel_synth_init () = let val paths = valOf (!current_pathstruct); @@ -302,7 +348,7 @@ fun next_experiment all_exps next_relation = handle NotFound => new_word_relation; val _ = printv 2 ("Calling Z3\n"); - val model = Z3_SAT_modelLib.Z3_GET_SAT_MODEL word_relation; + val model = scamv_get_model word_relation; val _ = min_verb 1 (fn () => (print "SAT model:\n"; print_model model; print "\nSAT model finished.\n")); val (ml, regs) = List.partition (fn el => (String.isSubstring (#1 el) "MEM_")) model From 4e0e9f9fe801b98cdb90410513536451fe5a2d0f Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 12:27:07 +0100 Subject: [PATCH 0020/1015] more digging --- .../example-HolSmt-simplification.sml | 30 ++++++++++++++++--- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/src/shared/examples/example-HolSmt-simplification.sml b/src/shared/examples/example-HolSmt-simplification.sml index 10d41d1ca..2229b40ed 100644 --- a/src/shared/examples/example-HolSmt-simplification.sml +++ b/src/shared/examples/example-HolSmt-simplification.sml @@ -1,5 +1,7 @@ open HolKernel Parse boolLib bossLib; +open wordsTheory; +open finite_mapTheory; val _ = Parse.current_backend := PPBackEnd.vt100_terminal; val _ = wordsLib.add_word_cast_printer (); @@ -11,7 +13,7 @@ val _ = Library.trace := 5; *) val mem1_var = mk_var ("MEM", “:word64 |-> word8”); -val mem2_var = mk_var ("MEM", “:word64 |-> word8”); +val mem2_var = mk_var ("MEM'", “:word64 |-> word8”); val term = “ (w2w (w2w (^mem1_var ' R1) :word64):word1) @@ -105,6 +107,7 @@ val term = “ ”; *) +(* val goal = ([], term) val (simplified_goal, _) = SolverSpec.simplify (SmtLib.SIMP_TAC false) goal @@ -113,15 +116,34 @@ val term = “ val _ = print ((Int.toString (List.length sg_tl)) ^ "\n"); val _ = print_term sg_t; val _ = List.map print_term sg_tl; +*) (* type_of term +*) + +val MEM_def = Define ‘MEM a b = T’; + +(* +val goal = ([]:term list, “^term”); +val (simplified_goals, _) = (Library.WORD_SIMP_TAC) goal; +val [([], sg_t)] = simplified_goals; +val _ = print_term sg_t; +*) + +val term = “((((0 :num) >< (0 :num)) :word64 -> word1) + ((w2w :word8 -> word64 ) + (((^mem1_var :word64 |-> word8) ' (R1 :word64)) :word8))) = + ((((0 :num) >< (0 :num)) :word8 -> word1) + (((^mem2_var :word64 |-> word8) ' (R2 :word64)) :word8))”; - val goal = ([]:term list, “^term”) -(Library.WORD_SIMP_TAC) - goal +(* +val goal = ([]:term list, “^term”); +CONV_TAC (DEPTH_CONV wordsLib.EXTEND_EXTRACT_CONV) goal; *) +(DEPTH_CONV wordsLib.EXTEND_EXTRACT_CONV) term; + (* Z3_SAT_modelLib.Z3_GET_SAT_MODEL term *) From 8d6778bace9317b50632268aa5c150dfd786161a Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 15:32:31 +0100 Subject: [PATCH 0021/1015] Add basic testing of HolSmt-based model exporter --- ...z3-sat-model.sml => test-z3-sat-model.sml} | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) rename src/shared/examples/{example-z3-sat-model.sml => test-z3-sat-model.sml} (58%) diff --git a/src/shared/examples/example-z3-sat-model.sml b/src/shared/examples/test-z3-sat-model.sml similarity index 58% rename from src/shared/examples/example-z3-sat-model.sml rename to src/shared/examples/test-z3-sat-model.sml index a1eb19a6d..a0d98e6ab 100644 --- a/src/shared/examples/example-z3-sat-model.sml +++ b/src/shared/examples/test-z3-sat-model.sml @@ -41,6 +41,11 @@ fun produce_sat_thm term model = prove (imp_tm, SIMP_TAC std_ss [] >> EVAL_TAC) end; +val model_eq = list_eq (pair_eq (fn (a:string) => fn (b:string) => a=b) identical); + + +(* ============================================================= *) + (* Get a SAT model using Z3 (this function assumes that the given term is SAT) *) val term = ``(z + y = 2 * x) /\ ((x * x + y - 25) = z:int)``; (* (FUN_MAP2 (K 0w) (UNIV)) *) @@ -51,3 +56,28 @@ val model = Z3_SAT_modelLib.Z3_GET_SAT_MODEL term; val _ = (print "SAT model:\n"; print_model model(*; print "\n"*)); val sat_thm = produce_sat_thm term model; val _ = (print "SAT thm:\n"; Hol_pp.print_thm sat_thm; print "\n"); + +val model_expected = [("z", “19:int”), ("y", “(-5):int”), ("x", “7:int”)]; + +val _ = if model_eq model model_expected then () else + raise Fail "model for simple int constraint not as expected."; + + +(* ============================================================= *) + +val term = “mem123 <> (FUN_FMAP (K (144w :word8) :word64 -> word8) 𝕌(:word64))”; +val model = Z3_SAT_modelLib.Z3_GET_SAT_MODEL term; +val model_expected = [("mem123", “FUN_FMAP ((K 144w) :word64 -> word8) 𝕌(:word64) |+ (0w,111w)”)]; + +val _ = if model_eq model model_expected then () else + raise Fail "model for memory inequality not as expected."; + + +(* ============================================================= *) + +val term = “mem123 <> (FUN_FMAP ((K 144w) :word64 -> word8) 𝕌(:word64) |+ (0w,111w))”; +val model = Z3_SAT_modelLib.Z3_GET_SAT_MODEL term; +val model_expected = [("mem123", “FUN_FMAP ((K 144w) :word64 -> word8) 𝕌(:word64) |+ (0w,144w)”)]; + +val _ = if model_eq model model_expected then () else + raise Fail "model for memory inequality not as expected."; From 22f558218b508fc96ec00655bb3cdbdad1e3b7e2 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 16:32:50 +0100 Subject: [PATCH 0022/1015] Restructure and fix and unify memory in "different state pair constraint" --- src/tools/scamv/bir_scamv_driverLib.sml | 119 +++++++++++++----------- src/tools/scamv/bir_utilLib.sml | 10 +- src/tools/scamv/scamv_trainingLib.sml | 3 + 3 files changed, 72 insertions(+), 60 deletions(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index 44ffb05ef..52d5b4841 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -222,8 +222,6 @@ val t = hd vars *) fun to_new_name n = "sv_" ^ (if String.isSuffix "'" n then (String.substring(n, 0, (String.size n)-1) ^ "_p") else n); - fun to_final_name n = - if String.isSuffix "'" n then (String.substring(n, 0, (String.size n)-1) ^ "_") else n; fun var_to_new t = let val (vn, vt) = dest_var t; @@ -237,7 +235,7 @@ val t = hd vars SOME (n,_) => n | NONE => raise ERR "scamv_get_model" "unexpected error"; in - (to_final_name n, v) + (n, v) end; val vars = free_vars word_relation; @@ -247,10 +245,60 @@ val t = hd vars val word_relation_newnames = subst (List.map (|->) vars_to_new) word_relation; val model_newnames = Z3_SAT_modelLib.Z3_GET_SAT_MODEL word_relation_newnames; val model = List.map (rev_model_name varnames_to_new) model_newnames; + val _ = min_verb 4 (fn () => (print "SAT model:\n"; print_model model; print "\nSAT model finished.\n")); + in model end; +(* +val model = [ + ("MEM", “FUN_FMAP ((K 0w) :word64->word8) 𝕌(:word64)”), + ("MEM'", “FUN_FMAP ((K 0w) :word64->word8) 𝕌(:word64)”), + ("R26", “0x80100020w:word64”), + ("R26'", “0x80100000w:word64”), + ("R28", “0x80100001w:word64”), + ("R28'", “0x80100000w:word64”) +]; +*) + +fun scamv_process_model model = + let + val (s1, s2) = + let + val (primed, nprimed) = List.partition ((String.isSuffix "'") o fst) model; + val primed_rm = List.map (fn (r,v) => ((remove_suffix "'") r,v)) primed; + in + (to_sml_Arbnums nprimed, to_sml_Arbnums primed_rm) + end; + +(* + fun to_final_name n = + if String.isSuffix "'" n then (String.substring(n, 0, (String.size n)-1) ^ "_") else n; + fun adjust_prime s = + if String.isSuffix "_" s + then String.map (fn c => if c = #"_" then #"'" else c) s + else s; +*) + + fun mk_var_val_mapping m = + let + fun mk_var_val_eq (n,v) = mk_eq (mk_var (n, type_of v), v); + in list_mk_conj (List.map mk_var_val_eq m) end; + +(* + fun is_a_mem (n,_) = String.isSubstring n "MEM_" andalso String.isSubstring "MEM" n; + val (_, regs) = List.partition is_a_mem model; +*) +(* + val regs_eq = mk_reg_var_mapping (regs); + val mem_eq = T; +*) + val constraint = mk_neg (mk_var_val_mapping model); + in + (s1, s2, constraint) + end; + fun scamv_phase_rel_synth_init () = let val paths = valOf (!current_pathstruct); @@ -277,33 +325,6 @@ fun all_obs_not_present { a_run = (_,a_obs), b_run = (_,b_obs) } = in check a_obs andalso check b_obs end; -(* This is used to build the next relation for path enumeration *) -fun mem_constraint [] = ``T`` - | mem_constraint mls = - let fun is_addr_numeral tm = tm |> pairSyntax.dest_pair |> fst |> (fn x => (rhs o concl o EVAL) ``w2n ^x``) |> is_numeral - fun adjust_prime s = - if String.isSuffix "_" s - then String.map (fn c => if c = #"_" then #"'" else c) s - else s - fun mk_cnst vname vls = - let - val toIntls = (snd o finite_mapSyntax.strip_fupdate) vls - val mem = mk_var (adjust_prime vname ,Type`:word64 |-> word8`) - val memconstraint = map (fn p => let val (t1,t2) = pairSyntax.dest_pair p - in - ``^mem ' (^t1) = ^t2`` - end) toIntls; - val mc_conj = foldl (fn (a,b) => mk_conj (a,b)) (hd memconstraint) (tl memconstraint); - in - (``~(^mc_conj)``, toIntls) - end - - val (hc, hv)::(tc, tv)::[] = (map (fn (vn, vl) => mk_cnst vn vl ) mls) - val mc_conj = mk_conj ((if is_addr_numeral (hd hv) then hc else ``T``), (if is_addr_numeral (hd tv) then tc else ``T``)) - in - mc_conj - end - fun next_experiment all_exps next_relation = let open bir_expLib; @@ -348,35 +369,25 @@ fun next_experiment all_exps next_relation = handle NotFound => new_word_relation; val _ = printv 2 ("Calling Z3\n"); - val model = scamv_get_model word_relation; - val _ = min_verb 1 (fn () => (print "SAT model:\n"; print_model model; print "\nSAT model finished.\n")); - - val (ml, regs) = List.partition (fn el => (String.isSubstring (#1 el) "MEM_")) model - val (primed, nprimed) = List.partition (isPrimedRun o fst) model - (* clean up s2 *) - val primed_rm = List.map (fn (r,v) => (remove_prime r,v)) primed - val s1 = to_sml_Arbnums nprimed; - val s2 = to_sml_Arbnums primed_rm; + val (s1, s2, new_constraint) = (scamv_process_model o scamv_get_model) word_relation; + val _ = min_verb 1 (fn () => + (print "s1:\n"; + machstate_print s1; + print "\n")); + val _ = min_verb 1 (fn () => + (print "s2:\n"; + machstate_print s2; + print "\n")); + val _ = min_verb 4 (fn () => + (print "new constraint:\n"; + print (term_to_string_sel new_constraint); + print "\n")); + val prog_id = case !current_prog_id of NONE => raise ERR "next_experiment" "currently no prog_id loaded" | SOME x => x; - fun mk_var_mapping s = - let fun mk_eq (a,b) = - let fun adjust_prime s = - if String.isSuffix "_" s - then String.map (fn c => if c = #"_" then #"'" else c) s - else s; - val va = mk_var (adjust_prime a,``:word64``); - in ``^va = ^b`` - end; - in list_mk_conj (map mk_eq s) end; - - val reg_constraint = ``~^(mk_var_mapping (regs))``; - val mem_constraint = mem_constraint ml; - val new_constraint = mk_conj (reg_constraint, mem_constraint); - val _ = current_visited_map := add_visited (!current_visited_map) path_spec new_constraint; val _ = diff --git a/src/tools/scamv/bir_utilLib.sml b/src/tools/scamv/bir_utilLib.sml index 194e9f48e..433a7d5a0 100644 --- a/src/tools/scamv/bir_utilLib.sml +++ b/src/tools/scamv/bir_utilLib.sml @@ -142,13 +142,11 @@ fun to_sml_Arbnums model = ) (machstate_empty Arbnum.zero) model end; -fun remove_prime str = - if String.isSuffix "_" str then - (String.extract(str, 0, SOME((String.size str) - 1))) +fun remove_suffix suff str = + if String.isSuffix suff str then + (String.extract(str, 0, SOME((String.size str) - (String.size suff)))) else - raise ERR "remove_prime" "there was no prime where there should be one"; - -fun isPrimedRun s = String.isSuffix "_" s; + raise ERR "remove_suffix" ("there was no suffix '" ^ suff ^ "' where there should be one"); fun bir_free_vars exp = let diff --git a/src/tools/scamv/scamv_trainingLib.sml b/src/tools/scamv/scamv_trainingLib.sml index b95adf15b..1726471c6 100644 --- a/src/tools/scamv/scamv_trainingLib.sml +++ b/src/tools/scamv/scamv_trainingLib.sml @@ -6,6 +6,9 @@ local val libname = "scamv_trainingLib" val ERR = Feedback.mk_HOL_ERR libname val wrap_exn = Feedback.wrap_exn libname + + fun isPrimedRun s = String.isSuffix "_" s; + fun remove_prime str = bir_utilLib.remove_suffix "_" str; in fun compute_training_state current_full_specs current_obs_projection current_word_rel current_path_id path_struct = From c3e19ff0bba9bc979840dda2b961216cf8911b7d Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 17:21:29 +0100 Subject: [PATCH 0023/1015] Add memory range check and Remove comments --- src/tools/scamv/bir_scamv_driverLib.sml | 17 ----------------- src/tools/scamv/persistence/experimentsLib.sig | 8 +++++--- src/tools/scamv/persistence/experimentsLib.sml | 12 ++++++++++++ 3 files changed, 17 insertions(+), 20 deletions(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index 52d5b4841..c227ca178 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -272,28 +272,11 @@ fun scamv_process_model model = (to_sml_Arbnums nprimed, to_sml_Arbnums primed_rm) end; -(* - fun to_final_name n = - if String.isSuffix "'" n then (String.substring(n, 0, (String.size n)-1) ^ "_") else n; - fun adjust_prime s = - if String.isSuffix "_" s - then String.map (fn c => if c = #"_" then #"'" else c) s - else s; -*) - fun mk_var_val_mapping m = let fun mk_var_val_eq (n,v) = mk_eq (mk_var (n, type_of v), v); in list_mk_conj (List.map mk_var_val_eq m) end; -(* - fun is_a_mem (n,_) = String.isSubstring n "MEM_" andalso String.isSubstring "MEM" n; - val (_, regs) = List.partition is_a_mem model; -*) -(* - val regs_eq = mk_reg_var_mapping (regs); - val mem_eq = T; -*) val constraint = mk_neg (mk_var_val_mapping model); in (s1, s2, constraint) diff --git a/src/tools/scamv/persistence/experimentsLib.sig b/src/tools/scamv/persistence/experimentsLib.sig index e079c4ba9..9bd0465e8 100644 --- a/src/tools/scamv/persistence/experimentsLib.sig +++ b/src/tools/scamv/persistence/experimentsLib.sig @@ -45,9 +45,11 @@ signature experimentsLib = sig (* embexp platform parameters *) (* ======================================== *) - val embexp_params_code : Arbnum.num (* base address for placement *) - val embexp_params_memory : Arbnum.num * Arbnum.num (* base, length *) + val embexp_params_code : Arbnum.num; (* base address for placement *) + val embexp_params_memory : Arbnum.num * Arbnum.num; (* base, length *) - val embexp_params_cacheable : Arbnum.num -> Arbnum.num + val embexp_params_cacheable : Arbnum.num -> Arbnum.num; + + val embexp_params_checkmemrange : machineState -> bool; end diff --git a/src/tools/scamv/persistence/experimentsLib.sml b/src/tools/scamv/persistence/experimentsLib.sml index 3f7687d44..915d9f6d2 100644 --- a/src/tools/scamv/persistence/experimentsLib.sml +++ b/src/tools/scamv/persistence/experimentsLib.sml @@ -284,6 +284,18 @@ in fun embexp_params_cacheable x = Arbnum.+ (Arbnum.fromInt 0x80000000, x); + fun embexp_params_checkmemrange (MACHSTATE (_, (_, _, m))) = + let + val addrs = List.map fst (Redblackmap.listItems m); + val addr_min = embexp_params_cacheable (fst embexp_params_memory); + val addr_max = Arbnum.+ (addr_min, snd embexp_params_memory); + + fun addr_in_range a = + Arbnum.<= (addr_min, a) andalso + Arbnum.< (a, addr_max); + in + List.all addr_in_range addrs + end; end (* local *) end (* struct *) From 774ece85f467a90a3e68f0eddc7c66deea314715 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 17:31:34 +0100 Subject: [PATCH 0024/1015] Make functions for scamv output verbosity more globally available within scamv --- src/tools/scamv/bir_scamv_driverLib.sml | 10 ---------- src/tools/scamv/bir_utilLib.sml | 10 ++++++++++ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index c227ca178..fc5de10bc 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -114,16 +114,6 @@ fun reset () = current_full_specs := []; current_word_rel := NONE); -fun printv n str = - if (#verbosity (scamv_getopt_config ()) >= n) - then print str - else (); - -fun min_verb n f = - if (#verbosity (scamv_getopt_config ()) >= n) - then f () - else (); - fun observe_line e = brshift (band (e, blshift (bconst64 0x7f, bconst64 6)), bconst64 6); diff --git a/src/tools/scamv/bir_utilLib.sml b/src/tools/scamv/bir_utilLib.sml index 433a7d5a0..06b349f5c 100644 --- a/src/tools/scamv/bir_utilLib.sml +++ b/src/tools/scamv/bir_utilLib.sml @@ -15,6 +15,16 @@ local in +fun printv n str = + if (#verbosity (scamv_configLib.scamv_getopt_config ()) >= n) + then print str + else (); + +fun min_verb n f = + if (#verbosity (scamv_configLib.scamv_getopt_config ()) >= n) + then f () + else (); + fun stateful_tabulate f = let val current = ref 0; fun next () = From 92d25c48effff639421e7aebc554436720faffa4 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 17:35:37 +0100 Subject: [PATCH 0025/1015] Enable memory range check and also print training state at verbosity level 1 --- src/tools/scamv/bir_scamv_driverLib.sml | 7 +++++++ src/tools/scamv/scamv_trainingLib.sml | 17 +++++++++++++++++ 2 files changed, 24 insertions(+) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index fc5de10bc..a73a7eef2 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -262,6 +262,13 @@ fun scamv_process_model model = (to_sml_Arbnums nprimed, to_sml_Arbnums primed_rm) end; + val _ = List.app (fn (st_n, st) => + if embexp_params_checkmemrange st then () else + raise ERR "scamv_process_model" + (st_n ^ " memory contains mapping out of experiment range." ^ + "is there a problem with the constraints?") + ) [("s1", s1), ("s2", s2)]; + fun mk_var_val_mapping m = let fun mk_var_val_eq (n,v) = mk_eq (mk_var (n, type_of v), v); diff --git a/src/tools/scamv/scamv_trainingLib.sml b/src/tools/scamv/scamv_trainingLib.sml index 1726471c6..1f1b64fb4 100644 --- a/src/tools/scamv/scamv_trainingLib.sml +++ b/src/tools/scamv/scamv_trainingLib.sml @@ -17,6 +17,7 @@ fun compute_training_state current_full_specs current_obs_projection open scamv_path_structLib; open bir_rel_synthLib; open bir_utilLib; + open experimentsLib; fun training_input_mining tries = if tries > 0 then @@ -45,6 +46,22 @@ fun compute_training_state current_full_specs current_obs_projection |> List.partition (isPrimedRun o fst) |> (List.map (fn (r,v) => (remove_prime r,v)) o #1) |> to_sml_Arbnums + |> (fn st => + if embexp_params_checkmemrange st then st else + raise ERR "scamv_process_model" + ("s_train" ^ " memory contains mapping out of experiment range." ^ + "is there a problem with the constraints?") + ) + + |> (fn st => + let + val _ = min_verb 1 (fn () => + (print "s_train:\n"; + machstate_print st; + print "\n")); + in + st + end) end; end From 6958cbcdf951a5914054763f0f89d023ce68e744 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 17:43:09 +0100 Subject: [PATCH 0026/1015] Remove the memory from the constraint again --- src/tools/scamv/bir_scamv_driverLib.sml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index a73a7eef2..4e123f456 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -274,7 +274,10 @@ fun scamv_process_model model = fun mk_var_val_eq (n,v) = mk_eq (mk_var (n, type_of v), v); in list_mk_conj (List.map mk_var_val_eq m) end; - val constraint = mk_neg (mk_var_val_mapping model); + (* filter the model for registers to create the constraint "different from this state pair" *) + fun is_a_mem (n,_) = List.exists (fn x => x = n) ["MEM'", "MEM"]; + val regs = List.filter (not o is_a_mem) model; + val constraint = mk_neg (mk_var_val_mapping regs); in (s1, s2, constraint) end; From 6df61d5b92f412d0283948c9376c356503c1a64b Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Thu, 18 Feb 2021 17:51:44 +0100 Subject: [PATCH 0027/1015] Disable raw model output on stderr in the sat case --- src/shared/z3_wrapper.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/shared/z3_wrapper.py b/src/shared/z3_wrapper.py index d0e1bee11..4a6a1356b 100755 --- a/src/shared/z3_wrapper.py +++ b/src/shared/z3_wrapper.py @@ -259,7 +259,7 @@ def main(): exit(0) else: print("sat") - print(s.model(), file=sys.stderr) + #print(s.model(), file=sys.stderr) model = s.model() hol_list = model_to_list(model) From 0d52873a2d2cbcd5ebbea887d483fb3722e5fb18 Mon Sep 17 00:00:00 2001 From: Hamed Date: Wed, 24 Feb 2021 11:41:12 +0100 Subject: [PATCH 0028/1015] minor change in printting the training path --- src/tools/scamv/scamv_trainingLib.sml | 43 +++++++++++++++------------ 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/src/tools/scamv/scamv_trainingLib.sml b/src/tools/scamv/scamv_trainingLib.sml index 1f1b64fb4..f149ae498 100644 --- a/src/tools/scamv/scamv_trainingLib.sml +++ b/src/tools/scamv/scamv_trainingLib.sml @@ -10,6 +10,7 @@ local fun isPrimedRun s = String.isSuffix "_" s; fun remove_prime str = bir_utilLib.remove_suffix "_" str; in +fun print_debug x = let val _ = print ("Reached here! \n") in x end; fun compute_training_state current_full_specs current_obs_projection current_word_rel current_path_id path_struct = let @@ -19,30 +20,34 @@ fun compute_training_state current_full_specs current_obs_projection open bir_utilLib; open experimentsLib; fun training_input_mining tries = - if tries > 0 - then - let val new_path = case get_distinct_path current_path_id path_struct of - [] => raise ERR "training_branch_predictor" + if tries > 0 + then + let val new_path = case get_distinct_path current_path_id path_struct of + [] => raise ERR "training_branch_predictor" ("no paths found distinct from path " ^ PolyML.makestring current_path_id) - | p::_ => p - val new_spec = lookup_spec (path_id_of new_path) (path_id_of new_path) current_full_specs; - val new_spec = case new_spec of - NONE => raise ERR "training_branch_predictor" + | p::_ => p + val new_spec = lookup_spec (path_id_of new_path) (path_id_of new_path) current_full_specs; + val new_spec = case new_spec of + NONE => raise ERR "training_branch_predictor" ("no path spec found that exercises path " ^ PolyML.makestring (path_id_of new_path)) - | SOME s => s - val new_word_relation = make_word_relation (rel_synth_jit new_spec current_obs_projection path_struct) false; - val _ = print ("Training path: " ^ PolyML.makestring new_path); - val training_relation = mk_conj (new_word_relation, current_word_rel); - val _ = print ("Calling Z3 to get training state\n") - in - (Z3_SAT_modelLib.Z3_GET_SAT_MODEL training_relation) - handle e => training_input_mining (tries - 1) - end - else raise ERR "training_branch_predictor" "not enough paths"; + | SOME s => s + val new_word_relation = make_word_relation (rel_synth_jit new_spec current_obs_projection path_struct) false; + + val _ = min_verb 4 (fn () => + (print ("Training path: " ^ PolyML.makestring new_path)) + ) + val training_relation = mk_conj (new_word_relation, current_word_rel); + val _ = print ("Calling Z3 to get training state\n") + in + (Z3_SAT_modelLib.Z3_GET_SAT_MODEL training_relation) + handle e => training_input_mining (tries - 1) + end + else raise ERR "training_branch_predictor" "not enough paths"; in - training_input_mining (num_paths path_struct) + + training_input_mining (num_paths path_struct) |> List.partition (isPrimedRun o fst) |> (List.map (fn (r,v) => (remove_prime r,v)) o #1) |> to_sml_Arbnums From d200f0d849e16e0038dd9f58f5f02f9598cb32b8 Mon Sep 17 00:00:00 2001 From: Hamed Date: Thu, 25 Feb 2021 09:46:48 +0100 Subject: [PATCH 0029/1015] straightline speculation prog generator --- src/tools/scamv/proggen/asm_genLib.sig | 2 + src/tools/scamv/proggen/asm_genLib.sml | 48 +++++++++++++++++++++ src/tools/scamv/proggen/bir_prog_genLib.sml | 1 + 3 files changed, 51 insertions(+) diff --git a/src/tools/scamv/proggen/asm_genLib.sig b/src/tools/scamv/proggen/asm_genLib.sig index 9d2fa5982..ac14ef0df 100644 --- a/src/tools/scamv/proggen/asm_genLib.sig +++ b/src/tools/scamv/proggen/asm_genLib.sig @@ -43,6 +43,8 @@ sig val arb_program_spectre_v1 : ArmInstruction list Gen; val arb_program_spectre_v1_mod1 : ArmInstruction list Gen; + val arb_program_straightline_branch : ArmInstruction list Gen; + val prog_gen_a_la_qc : ArmInstruction list Gen -> int -> string list; val prog_gen_a_la_qc_noresize : ArmInstruction list Gen -> int -> string list; diff --git a/src/tools/scamv/proggen/asm_genLib.sml b/src/tools/scamv/proggen/asm_genLib.sml index fb314d256..30c1d0170 100644 --- a/src/tools/scamv/proggen/asm_genLib.sml +++ b/src/tools/scamv/proggen/asm_genLib.sml @@ -362,6 +362,54 @@ in gen_arr_bnds_chck_acc_mod gen_arr_acc (return [Nop]); end; +(* =============== straightline speculation ================= *) +val arb_instruction_nobranch_nocmp = + frequency + [(1, arb_load_indir) + ,(1, arb_nop) + ,(1, arb_add)] + +val arb_program_nobranch_nocmp = arb_list_of arb_instruction_nobranch_nocmp; + +fun arb_program_straightline_cond arb_prog_left arb_prog_right = + let + fun rel_jmp_after bl = Imm (((length bl) + 1) * 4); + + val arb_prog = arb_prog_left >>= (fn blockl => + arb_prog_right >>= (fn blockr => + let val blockl_wexit = blockl@[Branch (NONE, rel_jmp_after blockr)] in + return ( + blockl_wexit + @blockr) + end + )); + in + arb_prog + end; + +val arb_program_straightline_branch = + let + val arb_pad = sized (fn n => choose (1, n)) >>= + (fn n => resize n arb_program_nobranch_nocmp); + + + val arb_load_instr = arb_load_indir; + + val arb_leftright = + arb_load_instr >>= (fn ld1 => + + let val arb_block_3ld = + (List.foldr (op@) []) <$> ( + sequence [return [ld1] + ,arb_pad + ,arb_pad + ]) in + two (arb_pad) arb_block_3ld + end + ); + in + arb_leftright >>= (fn (l,r) => arb_program_straightline_cond (return l) (return r)) + end; (* ================================ *) fun prog_gen_a_la_qc_gen do_resize gen n = diff --git a/src/tools/scamv/proggen/bir_prog_genLib.sml b/src/tools/scamv/proggen/bir_prog_genLib.sml index 53bfbfeec..c031079e6 100644 --- a/src/tools/scamv/proggen/bir_prog_genLib.sml +++ b/src/tools/scamv/proggen/bir_prog_genLib.sml @@ -223,6 +223,7 @@ fun pgen_qc_param param = | "xld_br_yld_mod1" => prog_gen_a_la_qc arb_program_xld_br_yld_mod1 | "spectre_v1" => prog_gen_a_la_qc arb_program_spectre_v1 | "spectre_v1_mod1" => prog_gen_a_la_qc arb_program_spectre_v1_mod1 + | "straightline_branch" => prog_gen_a_la_qc arb_program_straightline_branch | _ => raise ERR "prog_gen_store_a_la_qc" "unknown qc generator"; fun prog_gen_store_a_la_qc param sz = prog_gen_store ("prog_gen_a_la_qc::"^param) true From 13c18dc5566ad0bc6980090bfc51ff3dfb516aa2 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Tue, 2 Mar 2021 19:18:14 +0100 Subject: [PATCH 0030/1015] New observation model instrumentation code --- src/tools/scamv/obsmodel/bir_obs_modelLib.sml | 253 ++++++++---------- 1 file changed, 115 insertions(+), 138 deletions(-) diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml index 276fc3733..e7977653d 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml @@ -72,7 +72,6 @@ open bir_block_collectionLib; open bir_cfgLib; (* ================================================ *) - val Obs_dict = Redblackmap.insert (Redblackmap.mkDict Term.compare, ``dummy``, ([]:term list)); fun mk_key_from_address64 i addr = (mk_BL_Address o bir_immSyntax.mk_Imm64 o wordsSyntax.mk_word) (addr, Arbnum.fromInt i); (* single entry recursion, stop at first revisit or exit *) @@ -110,34 +109,25 @@ open bir_cfgLib; (entry::visited, acc_new) targets_to_visit end; - (* TODO ensure the lists of obs in the result are in program order *) - fun extract_branch_obs targets g depth bl_dict = - let - val f = (fn l => Redblackmap.find (bl_dict, l) - |> bir_programSyntax.dest_bir_block - |> not o listSyntax.is_nil o #2) - fun extract_obs labels = - List.map (fn label => - let val block = Redblackmap.find (bl_dict, label) - val (_, statements, _) = bir_programSyntax.dest_bir_block block - val obs = find_terms is_BStmt_Observe statements (* TODO this should be manual traversal to ensure preservation of program order *) - in - filter (fn obs => (#3 o dest_BStmt_Observe) obs - |> listSyntax.mk_hd - |> (rhs o concl o EVAL) - |> (not o is_BExp_Const)) obs - end) (rev (filter f labels)) (* TODO sort by program order *) - |> flatten - - val bn1::bn2::_ = List.map (fn t => fst (traverse_graph_branch g depth (t) [] [])) targets; - val b1_nodes = List.filter (fn x => (List.all (fn y => not (identical x y)) bn1)) bn2; - val b2_nodes = List.filter (fn x => (List.all (fn y => not (identical x y)) bn2)) bn1; - (* val _ = List.app print_term (extract_obs b1_nodes); *) - val Obs_dict = Redblackmap.insert(Obs_dict, hd targets, extract_obs b1_nodes); - val Obs_dict = Redblackmap.insert(Obs_dict, last targets, extract_obs b2_nodes); - in - Obs_dict - end + + (* given a branch, extract the statements of that branch as a list *) + fun extract_branch_stmts g depth branch bl_dict = + let + open listSyntax + val dest_list_ignore_type = fst o dest_list; + fun extract_stmts_from_lbl lbl = + let open bir_programSyntax; + val block = Redblackmap.find (bl_dict, lbl) + val (_, statements, _) = dest_bir_block block; + (* statements is a HOL list of BIR statements *) + in statements end; + + val (branch_labels,_) = traverse_graph_branch g depth branch [] []; + (* stmts is a (SML) list of BIR statements (HOL terms) *) + val stmts = List.map (dest_list_ignore_type o extract_stmts_from_lbl) (rev branch_labels); + in + List.concat stmts + end; fun nub_with eq [] = [] | nub_with eq (x::xs) = x::(nub_with eq (List.filter (fn y => not (eq (y, x))) xs)) @@ -172,124 +162,102 @@ open bir_cfgLib; nub_with (fn (x,y) => identical x y) fvs end; - fun Obs_prime xs = - let open stringSyntax numSyntax; - fun primed_subst exp = - List.map (fn v => - let val vp = lift_string string_ty (fromHOLstring v ^ "*") - in ``^v`` |-> ``^vp`` end) - (bir_free_vars exp) - fun Obs_prime_single x = - let val obs = x |> dest_BStmt_Observe |> #3 - val (id, a, b, c) = dest_BStmt_Observe x - val new_x = mk_BStmt_Observe (term_of_int 1, a, b, c) - in - List.foldl (fn (record, tm) => subst[#redex record |-> #residue record] tm) new_x (primed_subst obs) - end - in - map Obs_prime_single xs - end; - - fun Obs_prime_base xs = + fun primed_term t = let open stringSyntax numSyntax; fun primed_subst exp = List.map (fn v => let val vp = lift_string string_ty (fromHOLstring v ^ "*") in ``^v`` |-> ``^vp`` end) - (bir_free_vars exp) - fun Obs_prime_single proj_id x = - let val obs = x |> dest_BStmt_Observe |> #3 - val (id, a, b, c) = dest_BStmt_Observe x - val new_x = mk_BStmt_Observe (term_of_int proj_id, a, b, c) - in - List.foldl (fn (record, tm) => subst[#redex record |-> #residue record] tm) new_x (primed_subst obs) - end - in - case xs of - [] => [] - | y::ys => Obs_prime_single 0 y :: map (Obs_prime_single 1) ys - end - -(* - reside in bir_obs_modelScript.sml. cannot be here, otherwise this creates unfinished scratch theory - constrain_spec_obs_vars_def - append_list_def -*) - - fun mk_assign_mem_assert e = - let - open stringSyntax; - val mem_bounds = - let - open wordsSyntax - fun bir_embexp_params_cacheable x = Arbnum.+ (Arbnum.fromInt 0x80000000, x); - val (mem_base, mem_len) = (Arbnum.fromHexString "0x100000", Arbnum.fromHexString "0x40000") - val mem_end = (Arbnum.- (Arbnum.+ (mem_base, mem_len), Arbnum.fromInt 128)); - in - pairSyntax.mk_pair - (mk_wordi (bir_embexp_params_cacheable mem_base, 64), - mk_wordi (bir_embexp_params_cacheable mem_end, 64)) - end; - fun remove_prime str = - if String.isSuffix "*" str then - (String.extract(str, 0, SOME((String.size str) - 1))) - else - raise ERR "remove_prime" "there was no prime where there should be one" - val p_fv = bir_free_vars e; - val np_fv = map (fn x => (remove_prime (fromHOLstring x)) |> (fn y => lift_string string_ty y)) p_fv; - val p_exp = map (fn x => subst [``"template"``|-> x] ``(BVar "template" (BType_Imm Bit64))``) - p_fv; - val np_exp= map (fn x => subst[``"template"``|-> x]``(BExp_Den (BVar "template" (BType_Imm Bit64)))``) - np_fv; - val comb_p_np = zip p_exp np_exp; - val eq_assign = map (fn (a,b) => (rhs o concl o EVAL)``constrain_spec_obs_vars (^a,^b)``) comb_p_np - - (* gets list of observation statements - NB. we assume e is of the form produced in add_obs_speculative_exec - *) - val (obslist,_) = (listSyntax.dest_list o #2 o pairSyntax.dest_pair) e - handle _ => raise ERR "mk_assign_mem_assert" - ("ill-formed argument: " ^ term_to_string e ^ ", expected pair"); - in - case obslist of - [] => [] - | obs::_ => + (bir_free_vars exp) + in + List.foldl (fn (record, tm) => subst[#redex record |-> #residue record] tm) t (primed_subst t) + end + + fun const_obs t = + if is_BStmt_Observe t + then let open listSyntax; + val (_,_,obs_list_tm,_) = dest_BStmt_Observe t; + val (obs_list,_) = dest_list obs_list_tm; + in + length obs_list = 1 andalso is_BExp_Const (hd obs_list) + end + else false + + fun mk_preamble stmts = + let open stringSyntax; + val free_vars = nub_with (uncurry identical) + (List.concat (map bir_free_vars stmts)); + fun star_string str = + lift_string string_ty (fromHOLstring str ^ "*") + fun mk_assignment var = + let val var_type = + if fromHOLstring var = "MEM" + then “BType_Mem Bit64 Bit8” + else “BType_Imm Bit64” + val var_star_tm = “BVar ^(star_string var) ^var_type” + in inst [Type.alpha |-> Type`:bir_val_t`] + (mk_BStmt_Assign (var_star_tm, “BExp_Den (BVar ^var ^var_type)”)) + end; + in + List.map mk_assignment free_vars + end; + + (* generate shadow branch for a given branch (to be inserted in the other) *) + fun gen_shadow_branch obs_fun g depth dict branch = let - (* extract observed expression from first obs. stmt - NB. if add_obs code is well-behaved, this should never fail at dest_cons - because the list in a BStmt_Observe should always be nonempty - *) - val (obstm,_) = ((listSyntax.dest_cons o #3 o dest_BStmt_Observe) obs) - handle _ => raise ERR "mk_assign_mem_assert" - ("ill-formed subexpression in arg: " - ^ term_to_string obs ^ ", expected obs. stmt" - ^ " with nonempty obs. list"); - val memcnst = (rhs o concl o EVAL)``(constrain_mem ^(mem_bounds) ^obstm): bir_val_t bir_stmt_basic_t``; - in - rev(memcnst::eq_assign) (* eq_assign @ [memcnst] *) - end - end - - fun add_obs_speculative_exec obs_fun prog targets g depth dict = + open listSyntax + open pairSyntax + val stmts = extract_branch_stmts g depth branch dict; + val preamble = mk_preamble stmts; + (* add stars to every free variable *) + val stmts_starred = map primed_term stmts; + (* remove constant observations (pc observations) *) + val stmts_without_pc = filter (not o const_obs) stmts_starred; + (* tag observations as refinements, as per obs_fun + NB. Refinement will not work unless obs_fun tags + some observations with 1 *) + val stmts_obs_tagged = obs_fun stmts_without_pc + in + preamble @ stmts_obs_tagged + end + + (* generate shadow branches for a given cjmp *) + fun add_shadow_branches obs_fun g depth dict (left_branch, right_branch) prog = let open listSyntax open pairSyntax - val Obs_dict = extract_branch_obs targets g depth dict - |> (fst o (fn d => Redblackmap.remove (d, ``dummy``))) - val Obs_dict_primed = Redblackmap.map (fn (k,v) => obs_fun v) Obs_dict; - val Obs_lst_primed = map (fn tm => mk_pair(fst tm, mk_list(snd tm, ``:bir_val_t bir_stmt_basic_t``))) - (Redblackmap.listItems Obs_dict_primed) - val asserted_obs = map (fn e => mk_list((mk_assign_mem_assert e), ``:bir_val_t bir_stmt_basic_t``)) - Obs_lst_primed; - val zip_assertedObs_primed = zip Obs_lst_primed asserted_obs; - val Obs_lst = map (fn (a, b) => (rhs o concl o EVAL)``append_list ^a ^b`` ) zip_assertedObs_primed; + fun to_stmt_list xs = mk_list(xs, “:bir_val_t bir_stmt_basic_t”); + val gen_shadow = gen_shadow_branch obs_fun g depth dict; + val left_shadow = to_stmt_list (gen_shadow left_branch) + val right_shadow = to_stmt_list (gen_shadow right_branch); + fun prepend_block (itm, p) = + (rhs o concl o EVAL)``prepend_obs_in_bir_prog_block ^itm ^p`` in - foldl (fn(itm, p) => (rhs o concl o EVAL)``prepend_obs_in_bir_prog_block ^itm ^p``) - prog - Obs_lst + foldl prepend_block prog + [“(^left_branch, ^right_shadow)”, “(^right_branch, ^left_shadow)”] end - fun branch_instrumentation_obs obs_fun prog depth = + fun obs_refined n stm = + if is_BStmt_Observe stm + then let open numSyntax; + val (obs_id,cond,obs_list_tm,f) = dest_BStmt_Observe stm; + in + mk_BStmt_Observe (term_of_int n, cond, obs_list_tm, f) + end + else stm + + val obs_all_refined = List.map (obs_refined 1); + fun obs_all_refined_but_first stmts = + let fun go [] = [] + | go (stmt::stmts) = + if is_BStmt_Observe stmt + then obs_refined 0 stmt :: obs_all_refined stmts + else stmt :: go stmts + in + go stmts + end + + fun branch_instrumentation obs_fun prog depth = let (* build the dictionaries using the library under test *) val bl_dict = gen_block_dict prog; val lbl_tms = get_block_dict_keys bl_dict; @@ -300,9 +268,18 @@ open bir_cfgLib; val g1 = cfg_create "specExec" entries n_dict bl_dict; val (visited_nodes,cjmp_nodes) = traverse_graph g1 (hd (#CFGG_entries g1)) [] []; + (* targets: each element in this list is a two-element list of branch targets + there is one such element for each cjmp in the program *) val targets = map (fn i => #CFGN_targets (lookup_block_dict_value (#CFGG_node_dict g1) i "_" "_")) cjmp_nodes; + fun unpack_targets ts = + case ts of + left::right::_ => (left,right) + | _ => raise ERR "branch_instrumentation" "CJMP node without two targets" in - foldl (fn(ts, p) => add_obs_speculative_exec obs_fun p ts g1 depth bl_dict) prog targets + foldl (fn (ts, p) => + add_shadow_branches obs_fun g1 depth bl_dict (unpack_targets ts) p) + prog + targets end in @@ -314,7 +291,7 @@ in val obs_hol_type = ``bir_val_t``; val pipeline_depth = 3; fun add_obs mb t = - branch_instrumentation_obs Obs_prime (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; + branch_instrumentation obs_all_refined (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; end; structure bir_arm8_cache_speculation_first_model : OBS_MODEL = @@ -322,7 +299,7 @@ in val obs_hol_type = ``bir_val_t``; val pipeline_depth = 3; fun add_obs mb t = - branch_instrumentation_obs Obs_prime_base (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; + branch_instrumentation obs_all_refined_but_first (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; end; end (* local *) From ebb9ee79c1621639a6d655efe554bc5559646969 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Wed, 3 Mar 2021 18:05:15 +0100 Subject: [PATCH 0031/1015] Fixed obsmodel test cases --- src/tools/scamv/obsmodel/testcases/prog_2.sml | 409 ++++++++++-------- src/tools/scamv/obsmodel/testcases/prog_5.sml | 115 +++-- src/tools/scamv/obsmodel/testcases/prog_6.sml | 318 +++++++------- 3 files changed, 480 insertions(+), 362 deletions(-) diff --git a/src/tools/scamv/obsmodel/testcases/prog_2.sml b/src/tools/scamv/obsmodel/testcases/prog_2.sml index 7674f6364..b23469ea4 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_2.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_2.sml @@ -1115,195 +1115,258 @@ obs0 0x1C *) val prog_2_cache_speculation = `` -BirProgram - [<|bb_label := BL_Address (Imm64 0w); - bb_statements := - [BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 0w)] HD; - BStmt_Assert - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R24" (BType_Imm Bit64))) - (BExp_Den (BVar "R14" (BType_Imm Bit64)))) - (BExp_Const (Imm64 7w))) (BExp_Const (Imm64 0w))); - BStmt_Assert + BirProgram + [<|bb_label := BL_Address (Imm64 (0w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (0w :word64))] (HD :bir_val_t list -> bir_val_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 4291559424w)) - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R24" (BType_Imm Bit64))) - (BExp_Den (BVar "R14" (BType_Imm Bit64))))) - (BExp_BinPred BIExp_LessThan - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R24" (BType_Imm Bit64))) - (BExp_Den (BVar "R14" (BType_Imm Bit64)))) - (BExp_Const (Imm64 4291624832w)))); - BStmt_Observe 0 (BExp_Const (Imm1 1w)) - [BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R24" (BType_Imm Bit64))) - (BExp_Den (BVar "R14" (BType_Imm Bit64)))] HD; - BStmt_Assign (BVar "R26" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R24" (BType_Imm Bit64))) (BExp_Den (BVar "R14" (BType_Imm Bit64)))) - BEnd_LittleEndian Bit64)]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 4w)))|>; - <|bb_label := BL_Address (Imm64 4w); - bb_statements := - [BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 4w)] HD; - BStmt_Assert - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "R17" (BType_Imm Bit64))) - (BExp_Const (Imm64 7w))) (BExp_Const (Imm64 0w))); - BStmt_Assert + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R26" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (4w :word64))))|>; + <|bb_label := BL_Address (Imm64 (4w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (4w :word64))] (HD :bir_val_t list -> bir_val_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 4291559424w)) - (BExp_Den (BVar "R17" (BType_Imm Bit64)))) - (BExp_BinPred BIExp_LessThan - (BExp_Den (BVar "R17" (BType_Imm Bit64))) - (BExp_Const (Imm64 4291624832w)))); - BStmt_Observe 0 (BExp_Const (Imm1 1w)) - [BExp_Den (BVar "R17" (BType_Imm Bit64))] HD; - BStmt_Assign (BVar "R15" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) - (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian - Bit64)]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 8w)))|>; - <|bb_label := BL_Address (Imm64 8w); - bb_statements := - [BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 8w)] HD; - BStmt_Assign (BVar "ProcState_C" (BType_Imm Bit1)) + (BExp_Den (BVar "R17" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "R15" (BType_Imm Bit64))) - (BExp_Den (BVar "R14" (BType_Imm Bit64)))); - BStmt_Assign (BVar "ProcState_N" (BType_Imm Bit1)) + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R17" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R17" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R17" (BType_Imm Bit64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R15" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (8w :word64))))|>; + <|bb_label := BL_Address (Imm64 (8w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (8w :word64))] (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "ProcState_C" (BType_Imm Bit1)) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_N" (BType_Imm Bit1)) + (BExp_BinPred BIExp_SignedLessThan + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "R14" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_V" (BType_Imm Bit1)) + (BExp_BinPred BIExp_Equal (BExp_BinPred BIExp_SignedLessThan (BExp_BinExp BIExp_Minus (BExp_Den (BVar "R14" (BType_Imm Bit64))) (BExp_Den (BVar "R15" (BType_Imm Bit64)))) - (BExp_Const (Imm64 0w))); - BStmt_Assign (BVar "ProcState_V" (BType_Imm Bit1)) - (BExp_BinPred BIExp_Equal - (BExp_BinPred BIExp_SignedLessThan - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "R14" (BType_Imm Bit64))) - (BExp_Den (BVar "R15" (BType_Imm Bit64)))) - (BExp_Const (Imm64 0w))) - (BExp_BinPred BIExp_SignedLessOrEqual - (BExp_Den (BVar "R15" (BType_Imm Bit64))) - (BExp_Den (BVar "R14" (BType_Imm Bit64))))); - BStmt_Assign (BVar "ProcState_Z" (BType_Imm Bit1)) - (BExp_BinPred BIExp_Equal - (BExp_Den (BVar "R14" (BType_Imm Bit64))) - (BExp_Den (BVar "R15" (BType_Imm Bit64))))]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 12w)))|>; - <|bb_label := BL_Address (Imm64 12w); - bb_statements := - [BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 12w)] - HD]; - bb_last_statement := - BStmt_CJmp (BExp_Den (BVar "ProcState_Z" (BType_Imm Bit1))) - (BLE_Label (BL_Address (Imm64 24w))) - (BLE_Label (BL_Address (Imm64 16w)))|>; - <|bb_label := BL_Address (Imm64 16w); - bb_statements := - [BStmt_Assign (BVar "R9*" (BType_Imm Bit64)) - (BExp_Den (BVar "R9" (BType_Imm Bit64))); - BStmt_Assert + (BExp_Const (Imm64 (0w :word64)))) + (BExp_BinPred BIExp_SignedLessOrEqual + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64))))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_Z" (BType_Imm Bit1)) + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "R14" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64)))) : + bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (12w :word64))))|>; + <|bb_label := BL_Address (Imm64 (12w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (12w :word64))] + (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := + BStmt_CJmp (BExp_Den (BVar "ProcState_Z" (BType_Imm Bit1))) + (BLE_Label (BL_Address (Imm64 (24w :word64)))) + (BLE_Label (BL_Address (Imm64 (16w :word64))))|>; + <|bb_label := BL_Address (Imm64 (16w :word64)); + bb_statements := + [(BStmt_Assign (BVar "R9*" (BType_Imm Bit64)) + (BExp_Den (BVar "R9" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) + (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 2148532224w)) - (BExp_Den (BVar "R9*" (BType_Imm Bit64)))) - (BExp_BinPred BIExp_LessThan - (BExp_Den (BVar "R9*" (BType_Imm Bit64))) - (BExp_Const (Imm64 2148794240w)))); - BStmt_Observe 1 (BExp_Const (Imm1 1w)) - [BExp_Den (BVar "R9*" (BType_Imm Bit64))] HD; - BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 16w)] - HD; - BStmt_Assert - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R26" (BType_Imm Bit64))) - (BExp_Const (Imm64 4w))) (BExp_Const (Imm64 7w))) - (BExp_Const (Imm64 0w))); - BStmt_Assert + (BExp_Den (BVar "R9*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R9*" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R9*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (1 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R9*" (BType_Imm Bit64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R14" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R9*" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (16w :word64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 4291559424w)) - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R26" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w)))) - (BExp_BinPred BIExp_LessThan - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R26" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w))) - (BExp_Const (Imm64 4291624832w)))); - BStmt_Observe 0 (BExp_Const (Imm1 1w)) - [BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R26" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w))] HD; - BStmt_Assign (BVar "R10" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R26" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w))) BEnd_LittleEndian Bit64)]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 20w)))|>; - <|bb_label := BL_Address (Imm64 20w); - bb_statements := - [BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 20w)] - HD]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 28w)))|>; - <|bb_label := BL_Address (Imm64 24w); - bb_statements := - [BStmt_Assign (BVar "R26*" (BType_Imm Bit64)) - (BExp_Den (BVar "R26" (BType_Imm Bit64))); - BStmt_Assert + (BExp_Const (Imm64 (4w :word64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R10" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))) BEnd_LittleEndian Bit64) : + bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (20w :word64))))|>; + <|bb_label := BL_Address (Imm64 (20w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (20w :word64))] + (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (28w :word64))))|>; + <|bb_label := BL_Address (Imm64 (24w :word64)); + bb_statements := + [(BStmt_Assign (BVar "R26*" (BType_Imm Bit64)) + (BExp_Den (BVar "R26" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) + (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 2148532224w)) - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R26*" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w)))) - (BExp_BinPred BIExp_LessThan - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R26*" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w))) - (BExp_Const (Imm64 2148794240w)))); - BStmt_Observe 1 (BExp_Const (Imm1 1w)) - [BExp_BinExp BIExp_Plus + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (4w :word64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (1 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R26*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R10" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R26*" (BType_Imm Bit64))) - (BExp_Const (Imm64 76w))] HD; - BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 24w)] - HD; - BStmt_Assert - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "R9" (BType_Imm Bit64))) - (BExp_Const (Imm64 7w))) (BExp_Const (Imm64 0w))); - BStmt_Assert - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 4291559424w)) - (BExp_Den (BVar "R9" (BType_Imm Bit64)))) - (BExp_BinPred BIExp_LessThan - (BExp_Den (BVar "R9" (BType_Imm Bit64))) - (BExp_Const (Imm64 4291624832w)))); - BStmt_Observe 0 (BExp_Const (Imm1 1w)) - [BExp_Den (BVar "R9" (BType_Imm Bit64))] HD; - BStmt_Assign (BVar "R14" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) - (BExp_Den (BVar "R9" (BType_Imm Bit64))) BEnd_LittleEndian - Bit64)]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 28w)))|>; - <|bb_label := BL_Address (Imm64 28w); - bb_statements := - [BStmt_Observe 0 (BExp_Const (Imm1 1w)) [BExp_Const (Imm64 28w)] - HD]; bb_last_statement := BStmt_Halt (BExp_Const (Imm32 0w))|>] + (BExp_Const (Imm64 (76w :word64)))) BEnd_LittleEndian Bit64) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (24w :word64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And (BExp_Den (BVar "R9" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R9" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R9" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R9" (BType_Imm Bit64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R14" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R9" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (28w :word64))))|>; + <|bb_label := BL_Address (Imm64 (28w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (28w :word64))] + (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] :bir_val_t bir_program_t ``; diff --git a/src/tools/scamv/obsmodel/testcases/prog_5.sml b/src/tools/scamv/obsmodel/testcases/prog_5.sml index f1b8e677f..d37c83860 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_5.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_5.sml @@ -160,13 +160,13 @@ obs0 0x18 obs0 0x1C ================================= *) -val prog_5_cache_speculation_first = `` - BirProgram +val prog_5_cache_speculation_first = + “ +BirProgram [<|bb_label := BL_Address (Imm64 (0w :word64)); bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (0w :word64))] - (HD :bir_val_t list -> bir_val_t ); + [BExp_Const (Imm64 (0w :word64))] (HD :bir_val_t list -> bir_val_t); (BStmt_Assign (BVar "ProcState_C" (BType_Imm Bit1)) (BExp_BinPred BIExp_LessOrEqual (BExp_Den (BVar "R2" (BType_Imm Bit64))) @@ -198,8 +198,7 @@ val prog_5_cache_speculation_first = `` <|bb_label := BL_Address (Imm64 (4w :word64)); bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (4w :word64))] - (HD :bir_val_t list -> bir_val_t )]; + [BExp_Const (Imm64 (4w :word64))] (HD :bir_val_t list -> bir_val_t)]; bb_last_statement := BStmt_CJmp (BExp_Den (BVar "ProcState_C" (BType_Imm Bit1))) (BLE_Label (BL_Address (Imm64 (24w :word64)))) @@ -207,8 +206,7 @@ val prog_5_cache_speculation_first = `` <|bb_label := BL_Address (Imm64 (8w :word64)); bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (8w :word64))] - (HD :bir_val_t list -> bir_val_t ); + [BExp_Const (Imm64 (8w :word64))] (HD :bir_val_t list -> bir_val_t); (BStmt_Assert (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And @@ -220,7 +218,7 @@ val prog_5_cache_speculation_first = `` (BStmt_Assert (BExp_BinExp BIExp_And (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 (4291559424w :word64))) + (BExp_Const (Imm64 (0xFFCC0000w :word64))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1" (BType_Imm Bit64))) (BExp_Den (BVar "R3" (BType_Imm Bit64))))) @@ -228,12 +226,12 @@ val prog_5_cache_speculation_first = `` (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1" (BType_Imm Bit64))) (BExp_Den (BVar "R3" (BType_Imm Bit64)))) - (BExp_Const (Imm64 (4291624832w :word64))))) : + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : bir_val_t bir_stmt_basic_t); BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1" (BType_Imm Bit64))) (BExp_Den (BVar "R3" (BType_Imm Bit64)))] - (HD :bir_val_t list -> bir_val_t ); + (HD :bir_val_t list -> bir_val_t); (BStmt_Assign (BVar "R4" (BType_Imm Bit64)) (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus @@ -246,10 +244,10 @@ val prog_5_cache_speculation_first = `` bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Const (Imm64 (12w :word64))] - (HD :bir_val_t list -> bir_val_t ); + (HD :bir_val_t list -> bir_val_t); (BStmt_Assign (BVar "R4" (BType_Imm Bit64)) (BExp_BinExp BIExp_And - (BExp_Const (Imm64 (18446744073709551615w :word64))) + (BExp_Const (Imm64 (0xFFFFFFFFFFFFFFFFw :word64))) (BExp_BinExp BIExp_LeftShift (BExp_Den (BVar "R4" (BType_Imm Bit64))) (BExp_Const (Imm64 (6w :word64))))) : @@ -260,7 +258,7 @@ val prog_5_cache_speculation_first = `` bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Const (Imm64 (16w :word64))] - (HD :bir_val_t list -> bir_val_t ); + (HD :bir_val_t list -> bir_val_t); (BStmt_Assert (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And @@ -272,7 +270,7 @@ val prog_5_cache_speculation_first = `` (BStmt_Assert (BExp_BinExp BIExp_And (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 (4291559424w :word64))) + (BExp_Const (Imm64 (0xFFCC0000w :word64))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R5" (BType_Imm Bit64))) (BExp_Den (BVar "R4" (BType_Imm Bit64))))) @@ -280,12 +278,12 @@ val prog_5_cache_speculation_first = `` (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R5" (BType_Imm Bit64))) (BExp_Den (BVar "R4" (BType_Imm Bit64)))) - (BExp_Const (Imm64 (4291624832w :word64))))) : + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : bir_val_t bir_stmt_basic_t); BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R5" (BType_Imm Bit64))) (BExp_Den (BVar "R4" (BType_Imm Bit64)))] - (HD :bir_val_t list -> bir_val_t ); + (HD :bir_val_t list -> bir_val_t); (BStmt_Assign (BVar "R6" (BType_Imm Bit64)) (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus @@ -298,27 +296,38 @@ val prog_5_cache_speculation_first = `` bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Const (Imm64 (20w :word64))] - (HD :bir_val_t list -> bir_val_t )]; + (HD :bir_val_t list -> bir_val_t)]; bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 (28w :word64))))|>; <|bb_label := BL_Address (Imm64 (24w :word64)); bb_statements := - [(BStmt_Assign (BVar "R4*" (BType_Imm Bit64)) - (BExp_Den (BVar "R4" (BType_Imm Bit64))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assign (BVar "R5*" (BType_Imm Bit64)) - (BExp_Den (BVar "R5" (BType_Imm Bit64))) : + [(BStmt_Assign (BVar "R1*" (BType_Imm Bit64)) + (BExp_Den (BVar "R1" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); (BStmt_Assign (BVar "R3*" (BType_Imm Bit64)) (BExp_Den (BVar "R3" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); - (BStmt_Assign (BVar "R1*" (BType_Imm Bit64)) - (BExp_Den (BVar "R1" (BType_Imm Bit64))) : + (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) + (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "R4*" (BType_Imm Bit64)) + (BExp_Den (BVar "R4" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "R5*" (BType_Imm Bit64)) + (BExp_Den (BVar "R5" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R1*" (BType_Imm Bit64))) + (BExp_Den (BVar "R3*" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); (BStmt_Assert (BExp_BinExp BIExp_And (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 (2148532224w :word64))) + (BExp_Const (Imm64 (0xFFCC0000w :word64))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1*" (BType_Imm Bit64))) (BExp_Den (BVar "R3*" (BType_Imm Bit64))))) @@ -326,29 +335,69 @@ val prog_5_cache_speculation_first = `` (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1*" (BType_Imm Bit64))) (BExp_Den (BVar "R3*" (BType_Imm Bit64)))) - (BExp_Const (Imm64 (2148794240w :word64))))) : + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : bir_val_t bir_stmt_basic_t); BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1*" (BType_Imm Bit64))) (BExp_Den (BVar "R3*" (BType_Imm Bit64)))] - (HD :bir_val_t list -> bir_val_t ); + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R4" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R1*" (BType_Imm Bit64))) + (BExp_Den (BVar "R3*" (BType_Imm Bit64)))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "R4*" (BType_Imm Bit64)) + (BExp_BinExp BIExp_And + (BExp_Const (Imm64 (0xFFFFFFFFFFFFFFFFw :word64))) + (BExp_BinExp BIExp_LeftShift + (BExp_Den (BVar "R4*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (6w :word64))))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R5*" (BType_Imm Bit64))) + (BExp_Den (BVar "R4*" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R5*" (BType_Imm Bit64))) + (BExp_Den (BVar "R4*" (BType_Imm Bit64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R5*" (BType_Imm Bit64))) + (BExp_Den (BVar "R4*" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); BStmt_Observe (1 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R5*" (BType_Imm Bit64))) (BExp_Den (BVar "R4*" (BType_Imm Bit64)))] - (HD :bir_val_t list -> bir_val_t ); + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R6" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R5*" (BType_Imm Bit64))) + (BExp_Den (BVar "R4*" (BType_Imm Bit64)))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t); BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Const (Imm64 (24w :word64))] - (HD :bir_val_t list -> bir_val_t )]; + (HD :bir_val_t list -> bir_val_t)]; bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 (28w :word64))))|>; <|bb_label := BL_Address (Imm64 (28w :word64)); bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Const (Imm64 (28w :word64))] - (HD :bir_val_t list -> bir_val_t )]; + (HD :bir_val_t list -> bir_val_t)]; bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] -:bir_val_t bir_program_t -``; + :bir_val_t bir_program_t + ”; val prog_5_test = ("prog_5 - spectre_v1_mod1", prog_5, diff --git a/src/tools/scamv/obsmodel/testcases/prog_6.sml b/src/tools/scamv/obsmodel/testcases/prog_6.sml index dac1f141a..6d4ec3374 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_6.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_6.sml @@ -142,165 +142,171 @@ obs0 0x18 *) val prog_6_cache_speculation = `` BirProgram - [<|bb_label := BL_Address (Imm64 (0w :word64)); - bb_statements := - [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (0w :word64))] - (HD :bir_val_t list -> bir_val_t ); - (BStmt_Assert + [<|bb_label := BL_Address (Imm64 (0w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (0w :word64))] (HD :bir_val_t list -> bir_val_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "R27" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R27" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R27" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R27" (BType_Imm Bit64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R12" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R27" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (4w :word64))))|>; + <|bb_label := BL_Address (Imm64 (4w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (4w :word64))] (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "ProcState_C" (BType_Imm Bit1)) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "R16" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64)))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_N" (BType_Imm Bit1)) + (BExp_BinPred BIExp_SignedLessThan + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R16" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_V" (BType_Imm Bit1)) + (BExp_BinPred BIExp_Equal + (BExp_BinPred BIExp_SignedLessThan + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R16" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0w :word64)))) + (BExp_BinPred BIExp_SignedLessOrEqual + (BExp_Den (BVar "R16" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64))))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_Z" (BType_Imm Bit1)) + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R16" (BType_Imm Bit64)))) : + bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (8w :word64))))|>; + <|bb_label := BL_Address (Imm64 (8w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (8w :word64))] (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := + BStmt_CJmp + (BExp_BinExp BIExp_Or + (BExp_UnaryExp BIExp_Not (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "R27" (BType_Imm Bit64))) - (BExp_Const (Imm64 (7w :word64)))) - (BExp_Const (Imm64 (0w :word64)))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assert - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 (4291559424w :word64))) - (BExp_Den (BVar "R27" (BType_Imm Bit64)))) - (BExp_BinPred BIExp_LessThan - (BExp_Den (BVar "R27" (BType_Imm Bit64))) - (BExp_Const (Imm64 (4291624832w :word64))))) : - bir_val_t bir_stmt_basic_t); - BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Den (BVar "R27" (BType_Imm Bit64))] - (HD :bir_val_t list -> bir_val_t ); - (BStmt_Assign (BVar "R12" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) - (BExp_Den (BVar "R27" (BType_Imm Bit64))) BEnd_LittleEndian - Bit64) :bir_val_t bir_stmt_basic_t)]; - bb_last_statement := - BStmt_Jmp (BLE_Label (BL_Address (Imm64 (4w :word64))))|>; - <|bb_label := BL_Address (Imm64 (4w :word64)); - bb_statements := - [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (4w :word64))] - (HD :bir_val_t list -> bir_val_t ); - (BStmt_Assign (BVar "ProcState_C" (BType_Imm Bit1)) - (BExp_BinPred BIExp_LessOrEqual - (BExp_Den (BVar "R16" (BType_Imm Bit64))) - (BExp_Den (BVar "R15" (BType_Imm Bit64)))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assign (BVar "ProcState_N" (BType_Imm Bit1)) - (BExp_BinPred BIExp_SignedLessThan - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "R15" (BType_Imm Bit64))) - (BExp_Den (BVar "R16" (BType_Imm Bit64)))) - (BExp_Const (Imm64 (0w :word64)))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assign (BVar "ProcState_V" (BType_Imm Bit1)) - (BExp_BinPred BIExp_Equal - (BExp_BinPred BIExp_SignedLessThan - (BExp_BinExp BIExp_Minus - (BExp_Den (BVar "R15" (BType_Imm Bit64))) - (BExp_Den (BVar "R16" (BType_Imm Bit64)))) - (BExp_Const (Imm64 (0w :word64)))) - (BExp_BinPred BIExp_SignedLessOrEqual - (BExp_Den (BVar "R16" (BType_Imm Bit64))) - (BExp_Den (BVar "R15" (BType_Imm Bit64))))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assign (BVar "ProcState_Z" (BType_Imm Bit1)) - (BExp_BinPred BIExp_Equal - (BExp_Den (BVar "R15" (BType_Imm Bit64))) - (BExp_Den (BVar "R16" (BType_Imm Bit64)))) : - bir_val_t bir_stmt_basic_t)]; - bb_last_statement := - BStmt_Jmp (BLE_Label (BL_Address (Imm64 (8w :word64))))|>; - <|bb_label := BL_Address (Imm64 (8w :word64)); - bb_statements := - [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (8w :word64))] - (HD :bir_val_t list -> bir_val_t )]; - bb_last_statement := - BStmt_CJmp - (BExp_BinExp BIExp_Or - (BExp_UnaryExp BIExp_Not - (BExp_BinPred BIExp_Equal - (BExp_Den (BVar "ProcState_N" (BType_Imm Bit1))) - (BExp_Den (BVar "ProcState_V" (BType_Imm Bit1))))) - (BExp_Den (BVar "ProcState_Z" (BType_Imm Bit1)))) - (BLE_Label (BL_Address (Imm64 (12w :word64)))) - (BLE_Label (BL_Address (Imm64 (20w :word64))))|>; - <|bb_label := BL_Address (Imm64 (12w :word64)); - bb_statements := - [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (12w :word64))] - (HD :bir_val_t list -> bir_val_t ); - (BStmt_Assert - (BExp_BinPred BIExp_Equal - (BExp_BinExp BIExp_And - (BExp_Den (BVar "R8" (BType_Imm Bit64))) - (BExp_Const (Imm64 (7w :word64)))) - (BExp_Const (Imm64 (0w :word64)))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assert - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 (4291559424w :word64))) - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R8" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64))))) - (BExp_BinPred BIExp_LessThan - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R8" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64)))) - (BExp_Const (Imm64 (4291624832w :word64))))) : - bir_val_t bir_stmt_basic_t); - BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_BinExp BIExp_Plus + (BExp_Den (BVar "ProcState_N" (BType_Imm Bit1))) + (BExp_Den (BVar "ProcState_V" (BType_Imm Bit1))))) + (BExp_Den (BVar "ProcState_Z" (BType_Imm Bit1)))) + (BLE_Label (BL_Address (Imm64 (12w :word64)))) + (BLE_Label (BL_Address (Imm64 (20w :word64))))|>; + <|bb_label := BL_Address (Imm64 (12w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (12w :word64))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And (BExp_Den (BVar "R8" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R8" (BType_Imm Bit64))) + (BExp_Const (Imm64 (8w :word64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R8" (BType_Imm Bit64))) + (BExp_Const (Imm64 (8w :word64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R8" (BType_Imm Bit64))) + (BExp_Const (Imm64 (8w :word64)))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R8" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R8" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64)))] - (HD :bir_val_t list -> bir_val_t ); - (BStmt_Assign (BVar "R8" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R8" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64)))) BEnd_LittleEndian - Bit64) :bir_val_t bir_stmt_basic_t)]; - bb_last_statement := - BStmt_Jmp (BLE_Label (BL_Address (Imm64 (16w :word64))))|>; - <|bb_label := BL_Address (Imm64 (16w :word64)); - bb_statements := - [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (16w :word64))] - (HD :bir_val_t list -> bir_val_t )]; - bb_last_statement := - BStmt_Jmp (BLE_Label (BL_Address (Imm64 (24w :word64))))|>; - <|bb_label := BL_Address (Imm64 (20w :word64)); - bb_statements := - [(BStmt_Assign (BVar "R8*" (BType_Imm Bit64)) - (BExp_Den (BVar "R8" (BType_Imm Bit64))) : - bir_val_t bir_stmt_basic_t); - (BStmt_Assert - (BExp_BinExp BIExp_And - (BExp_BinPred BIExp_LessOrEqual - (BExp_Const (Imm64 (2148532224w :word64))) - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R8*" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64))))) - (BExp_BinPred BIExp_LessThan - (BExp_BinExp BIExp_Plus - (BExp_Den (BVar "R8*" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64)))) - (BExp_Const (Imm64 (2148794240w :word64))))) : - bir_val_t bir_stmt_basic_t); - BStmt_Observe (1 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_BinExp BIExp_Plus + (BExp_Const (Imm64 (8w :word64)))) BEnd_LittleEndian Bit64) : + bir_val_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (16w :word64))))|>; + <|bb_label := BL_Address (Imm64 (16w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (16w :word64))] + (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (24w :word64))))|>; + <|bb_label := BL_Address (Imm64 (20w :word64)); + bb_statements := + [(BStmt_Assign (BVar "R8*" (BType_Imm Bit64)) + (BExp_Den (BVar "R8" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) + (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : + bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "R8*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) :bir_val_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R8*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (8w :word64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R8*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (8w :word64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (1 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R8*" (BType_Imm Bit64))) + (BExp_Const (Imm64 (8w :word64)))] + (HD :bir_val_t list -> bir_val_t); + (BStmt_Assign (BVar "R8*" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R8*" (BType_Imm Bit64))) - (BExp_Const (Imm64 (8w :word64)))] - (HD :bir_val_t list -> bir_val_t ); - BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (20w :word64))] - (HD :bir_val_t list -> bir_val_t )]; - bb_last_statement := - BStmt_Jmp (BLE_Label (BL_Address (Imm64 (24w :word64))))|>; - <|bb_label := BL_Address (Imm64 (24w :word64)); - bb_statements := - [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Const (Imm64 (24w :word64))] - (HD :bir_val_t list -> bir_val_t )]; - bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] + (BExp_Const (Imm64 (8w :word64)))) BEnd_LittleEndian Bit64) : + bir_val_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (20w :word64))] + (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (24w :word64))))|>; + <|bb_label := BL_Address (Imm64 (24w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (24w :word64))] + (HD :bir_val_t list -> bir_val_t)]; + bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] :bir_val_t bir_program_t ``; From 579aca463a0f2b22677e25d85b420744ae48e894 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 6 Apr 2021 01:21:25 +0200 Subject: [PATCH 0032/1015] Add storing the relative time of experiment creation --- src/tools/scamv/persistence/persistenceLib.sml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/tools/scamv/persistence/persistenceLib.sml b/src/tools/scamv/persistence/persistenceLib.sml index 3ea9047ae..7dded141d 100644 --- a/src/tools/scamv/persistence/persistenceLib.sml +++ b/src/tools/scamv/persistence/persistenceLib.sml @@ -209,6 +209,12 @@ struct holba_run_id_create descr_o; ()); + fun timer_stop_gen f NONE = raise ERR "timer_stop_gen" "this should not happen" + | timer_stop_gen f (SOME tm) = let + val d_time = Time.- (Time.now(), tm); + in f ((Time.toString d_time) ^ "s") end; + fun time_since_run_str () = timer_stop_gen (fn x => x) (!holba_run_timer_ref); + (* storing to logs *) (* ========================================================================================= *) fun run_create_prog arch prog run_metadata = @@ -248,6 +254,7 @@ struct val exp_type_s = exp_type_to_string exp_type; val RunReferences (_, run_name, _, exp_l_id) = holba_run_id(); + val run_metadata_ = ("time", time_since_run_str ())::run_metadata; val input_data = Json.OBJECT (List.map (fn (n, s) => ("input_" ^ n, machstate_to_Json s)) state_list); val exp_v = LogsExp (prog_id, exp_type_s, exp_params, input_data); @@ -269,7 +276,7 @@ struct (* add metadata *) val meta_name = meta_name_log ^ "." ^ (get_dotfree_time ()); val _ = List.map (fn (m_n, m_v) => - init_meta (mk_exp_meta_handle (exp_id, SOME m_n, meta_name)) (SOME m_v)) run_metadata; + init_meta (mk_exp_meta_handle (exp_id, SOME m_n, meta_name)) (SOME m_v)) run_metadata_; in exp_id end; From e8fdb56f3603fc79d0d9385e38bafb289b7aa0ca Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 6 Apr 2021 18:11:27 +0200 Subject: [PATCH 0033/1015] Fix metadata name --- src/tools/scamv/persistence/persistenceLib.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/scamv/persistence/persistenceLib.sml b/src/tools/scamv/persistence/persistenceLib.sml index 7dded141d..288aa42d8 100644 --- a/src/tools/scamv/persistence/persistenceLib.sml +++ b/src/tools/scamv/persistence/persistenceLib.sml @@ -254,7 +254,7 @@ struct val exp_type_s = exp_type_to_string exp_type; val RunReferences (_, run_name, _, exp_l_id) = holba_run_id(); - val run_metadata_ = ("time", time_since_run_str ())::run_metadata; + val run_metadata_ = ("creationtime", time_since_run_str ())::run_metadata; val input_data = Json.OBJECT (List.map (fn (n, s) => ("input_" ^ n, machstate_to_Json s)) state_list); val exp_v = LogsExp (prog_id, exp_type_s, exp_params, input_data); From 1b8a60f6da96c9c358abee8ff083fe51f5e2017b Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Wed, 7 Apr 2021 12:15:22 +0200 Subject: [PATCH 0034/1015] bir_free_vars hotfix --- src/tools/scamv/obsmodel/bir_obs_modelLib.sml | 24 ++++++++++++++++--- src/tools/scamv/obsmodel/testcases/prog_2.sml | 19 +++++++++------ src/tools/scamv/obsmodel/testcases/prog_5.sml | 13 ++++++---- 3 files changed, 41 insertions(+), 15 deletions(-) diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml index e7977653d..f437e0dc4 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml @@ -162,13 +162,31 @@ open bir_cfgLib; nub_with (fn (x,y) => identical x y) fvs end; + fun bir_free_vars_stmt_b stmt_b = + let + open stringSyntax; + open bir_envSyntax; + open bir_programSyntax; + val fvs = + if is_BStmt_Assign stmt_b + then + let val (var,exp) = dest_BStmt_Assign stmt_b + in + (fst (dest_BVar var))::(bir_free_vars exp) + end + else + bir_free_vars stmt_b; + in + nub_with (fn (x,y) => identical x y) fvs + end; + fun primed_term t = let open stringSyntax numSyntax; - fun primed_subst exp = + fun primed_subst tm = List.map (fn v => let val vp = lift_string string_ty (fromHOLstring v ^ "*") in ``^v`` |-> ``^vp`` end) - (bir_free_vars exp) + (bir_free_vars_stmt_b tm) in List.foldl (fn (record, tm) => subst[#redex record |-> #residue record] tm) t (primed_subst t) end @@ -186,7 +204,7 @@ open bir_cfgLib; fun mk_preamble stmts = let open stringSyntax; val free_vars = nub_with (uncurry identical) - (List.concat (map bir_free_vars stmts)); + (List.concat (map bir_free_vars_stmt_b stmts)); fun star_string str = lift_string string_ty (fromHOLstring str ^ "*") fun mk_assignment var = diff --git a/src/tools/scamv/obsmodel/testcases/prog_2.sml b/src/tools/scamv/obsmodel/testcases/prog_2.sml index b23469ea4..812846cee 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_2.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_2.sml @@ -1114,9 +1114,9 @@ obs0 0x1C ================================= *) -val prog_2_cache_speculation = `` - BirProgram - [<|bb_label := BL_Address (Imm64 (0w :word64)); +val prog_2_cache_speculation = + ``BirProgram + [<|bb_label := BL_Address (Imm64 (0w :word64)); bb_statements := [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Const (Imm64 (0w :word64))] (HD :bir_val_t list -> bir_val_t); @@ -1228,6 +1228,9 @@ val prog_2_cache_speculation = `` [(BStmt_Assign (BVar "R9*" (BType_Imm Bit64)) (BExp_Den (BVar "R9" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "R14*" (BType_Imm Bit64)) + (BExp_Den (BVar "R14" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : bir_val_t bir_stmt_basic_t); @@ -1249,7 +1252,7 @@ val prog_2_cache_speculation = `` BStmt_Observe (1 :num) (BExp_Const (Imm1 (1w :word1))) [BExp_Den (BVar "R9*" (BType_Imm Bit64))] (HD :bir_val_t list -> bir_val_t); - (BStmt_Assign (BVar "R14" (BType_Imm Bit64)) + (BStmt_Assign (BVar "R14*" (BType_Imm Bit64)) (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) (BExp_Den (BVar "R9*" (BType_Imm Bit64))) BEnd_LittleEndian Bit64) :bir_val_t bir_stmt_basic_t); @@ -1301,6 +1304,9 @@ val prog_2_cache_speculation = `` [(BStmt_Assign (BVar "R26*" (BType_Imm Bit64)) (BExp_Den (BVar "R26" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "R10*" (BType_Imm Bit64)) + (BExp_Den (BVar "R10" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : bir_val_t bir_stmt_basic_t); @@ -1329,7 +1335,7 @@ val prog_2_cache_speculation = `` [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R26*" (BType_Imm Bit64))) (BExp_Const (Imm64 (76w :word64)))] (HD :bir_val_t list -> bir_val_t); - (BStmt_Assign (BVar "R10" (BType_Imm Bit64)) + (BStmt_Assign (BVar "R10*" (BType_Imm Bit64)) (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R26*" (BType_Imm Bit64))) @@ -1367,8 +1373,7 @@ val prog_2_cache_speculation = `` [BExp_Const (Imm64 (28w :word64))] (HD :bir_val_t list -> bir_val_t)]; bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] -:bir_val_t bir_program_t -``; +:bir_val_t bir_program_t``; val prog_2_cache_speculation_first = `` F diff --git a/src/tools/scamv/obsmodel/testcases/prog_5.sml b/src/tools/scamv/obsmodel/testcases/prog_5.sml index d37c83860..1e2a4e78b 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_5.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_5.sml @@ -307,15 +307,18 @@ BirProgram (BStmt_Assign (BVar "R3*" (BType_Imm Bit64)) (BExp_Den (BVar "R3" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); - (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) - (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : - bir_val_t bir_stmt_basic_t); (BStmt_Assign (BVar "R4*" (BType_Imm Bit64)) (BExp_Den (BVar "R4" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "MEM*" (BType_Mem Bit64 Bit8)) + (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) : + bir_val_t bir_stmt_basic_t); (BStmt_Assign (BVar "R5*" (BType_Imm Bit64)) (BExp_Den (BVar "R5" (BType_Imm Bit64))) : bir_val_t bir_stmt_basic_t); + (BStmt_Assign (BVar "R6*" (BType_Imm Bit64)) + (BExp_Den (BVar "R6" (BType_Imm Bit64))) : + bir_val_t bir_stmt_basic_t); (BStmt_Assert (BExp_BinPred BIExp_Equal (BExp_BinExp BIExp_And @@ -341,7 +344,7 @@ BirProgram [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1*" (BType_Imm Bit64))) (BExp_Den (BVar "R3*" (BType_Imm Bit64)))] (HD :bir_val_t list -> bir_val_t); - (BStmt_Assign (BVar "R4" (BType_Imm Bit64)) + (BStmt_Assign (BVar "R4*" (BType_Imm Bit64)) (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R1*" (BType_Imm Bit64))) @@ -379,7 +382,7 @@ BirProgram [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R5*" (BType_Imm Bit64))) (BExp_Den (BVar "R4*" (BType_Imm Bit64)))] (HD :bir_val_t list -> bir_val_t); - (BStmt_Assign (BVar "R6" (BType_Imm Bit64)) + (BStmt_Assign (BVar "R6*" (BType_Imm Bit64)) (BExp_Load (BExp_Den (BVar "MEM*" (BType_Mem Bit64 Bit8))) (BExp_BinExp BIExp_Plus (BExp_Den (BVar "R5*" (BType_Imm Bit64))) From a7d99a6aed2b8aa007dbf62ed53cc8a94e087513 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Wed, 7 Apr 2021 13:47:43 +0200 Subject: [PATCH 0035/1015] Add definitions of ijr step and simulation, and simulation theorem for ijr step (#1) * Add definition of ijr step (resolved_def) * Add definition of simulation (simulated_def) * Add simulation theorem (resolved_simulated) * Add definition of contract simulation and contract transfer theorem stub --- examples/ijr/contractTransferScript.sml | 54 +++ examples/ijr/resolutionScript.sml | 67 +++ examples/ijr/simulationScript.sml | 519 ++++++++++++++++++++++++ 3 files changed, 640 insertions(+) create mode 100644 examples/ijr/contractTransferScript.sml create mode 100644 examples/ijr/resolutionScript.sml create mode 100644 examples/ijr/simulationScript.sml diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml new file mode 100644 index 000000000..56c374e1d --- /dev/null +++ b/examples/ijr/contractTransferScript.sml @@ -0,0 +1,54 @@ +open HolKernel Parse boolLib bossLib; + +open bir_programTheory bir_htTheory; +open HolBACoreSimps; + +val _ = new_theory "contractTransfer"; + + +Definition contract_simulated_def: + contract_simulated p p' = + ∀s l ls s' o2 m2 n2. + s.bst_pc = bir_block_pc l ⇒ + MEM l (bir_labels_of_program p) ⇒ + (∀l'. l' IN ls ⇒ MEM l' (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels ls p' s = BER_Ended o2 m2 n2 s' ⇒ + ~(∃l'. s'.bst_status = BST_JumpOutside l') ⇒ + (∃o1 m1 n1. + bir_exec_to_labels ls p s = BER_Ended o1 m1 n1 s') +End + +Theorem contract_transfer: + ∀ (p' : 'a bir_program_t) l ls pre post (p : 'a bir_program_t). + contract_simulated p p' ⇒ + bir_vars_of_program p' = bir_vars_of_program p ⇒ + + MEM l (bir_labels_of_program p) ⇒ + (∀l'. l' IN ls ⇒ MEM l' (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels_triple p' l ls pre post ⇒ + bir_exec_to_labels_triple p l ls pre post +Proof +SIMP_TAC std_ss [bir_exec_to_labels_triple_def] >> +REPEAT STRIP_TAC >> +Q.PAT_X_ASSUM ‘∀s'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘s’ thm)) >> +REV_FULL_SIMP_TAC std_ss [] >> +rename1 ‘_ = BER_Ended o2 m2 n2 s'’ >> + +subgoal ‘∃s1 o1 m1 n1. + bir_exec_to_labels ls p s = BER_Ended o1 m1 n1 s'’ >- ( + ‘s.bst_pc = bir_block_pc l’ by ( + ASM_SIMP_TAC (std_ss++holBACore_ss) + [bir_block_pc_def, bir_programcounter_t_component_equality] + ) >> + ‘~(∃l'. s'.bst_status = BST_JumpOutside l')’ by + ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + METIS_TAC [contract_simulated_def] +) >> + +PROVE_TAC [] +QED + + +val _ = export_theory(); diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml new file mode 100644 index 000000000..4405fc1ac --- /dev/null +++ b/examples/ijr/resolutionScript.sml @@ -0,0 +1,67 @@ +open HolKernel Parse boolLib bossLib; + +open listTheory; + +open bir_programTheory bir_expTheory bir_exp_immTheory; +open bir_program_blocksTheory bir_program_multistep_propsTheory; +open HolBACoreSimps; + +val _ = new_theory "resolution"; + + +Inductive resolved_block_def: + ∀l1 v sl bl1 bl2 bl3 bss e c. + type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ∧ + + bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ∧ + c = BExp_BinPred BIExp_Equal e (BExp_Const v) ∧ + bl2 = bir_block_t l1 bss + (BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl))) ∧ + bl3 = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ + resolved_block l1 v sl bl1 bl2 bl3 +End + +Definition direct_jump_target_block_def: + direct_jump_target_block l bl = + ∀es. + es = bl.bb_last_statement ⇒ + (es = BStmt_Jmp (BLE_Label l) ∨ + ∃c l2. es = BStmt_CJmp c (BLE_Label l) l2 ∨ + ∃c l1. es = BStmt_CJmp c l1 (BLE_Label l)) +End + +Definition direct_jump_target_def: + direct_jump_target l p = + ∃l' bl. + bir_get_current_block p (bir_block_pc l') = SOME bl ⇒ + direct_jump_target_block l bl +End + +Definition fresh_label_def: + fresh_label l p = + (~(MEM l (bir_labels_of_program p)) ∧ + ~(direct_jump_target l p)) +End + +Inductive resolved_def: + ∀l1 v sl p p' bl1 bl2 bl3. + fresh_label (BL_Label sl) p ∧ + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ∧ + (MEM (BL_Address v) (bir_labels_of_program p)) ∧ + + bir_get_current_block p (bir_block_pc l1) = SOME bl1 ∧ + bir_get_current_block p' (bir_block_pc l1) = SOME bl2 ∧ + bir_get_current_block p' (bir_block_pc (BL_Label sl)) = SOME bl3 ∧ + resolved_block l1 v sl bl1 bl2 bl3 ∧ + + (∀l. MEM l (bir_labels_of_program p) ∧ l ≠ l1 ⇒ + ∃bl. bir_get_current_block p (bir_block_pc l) = SOME bl ∧ + bir_get_current_block p' (bir_block_pc l) = SOME bl) ⇒ + + resolved l1 v sl p p' +End + + +val _ = export_theory(); + diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml new file mode 100644 index 000000000..47e0ef159 --- /dev/null +++ b/examples/ijr/simulationScript.sml @@ -0,0 +1,519 @@ +open HolKernel Parse boolLib bossLib; + +open listTheory; + +open bir_programTheory bir_expTheory bir_exp_immTheory bir_typing_expTheory; +open bir_program_blocksTheory bir_program_multistep_propsTheory; +open HolBACoreSimps; + +open resolutionTheory; + +val _ = new_theory "simulation"; + + +Definition exec_to_prog_def: + exec_to_prog p s pls = + bir_exec_to_labels (set (bir_labels_of_program pls)) p s +End + +Definition simulated_def: + simulated p p' = + ∀s l s' o2 m2 n2. + s.bst_pc = bir_block_pc l ⇒ + MEM l (bir_labels_of_program p) ⇒ + exec_to_prog p' s p = BER_Ended o2 m2 n2 s' ⇒ + ~(∃l'. s'.bst_status = BST_JumpOutside l') ⇒ + (∃o1 m1 n1. + exec_to_prog p s p = BER_Ended o1 m1 n1 s') +End + + +Theorem bir_exec_stmt_jmp_to_label_same: + ∀l p' p s s'. + (MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) ⇒ + bir_exec_stmt_jmp_to_label p' l s = s' ⇒ + bir_exec_stmt_jmp_to_label p l s = s' +Proof +SIMP_TAC std_ss [bir_exec_stmt_jmp_to_label_def] +QED + +Theorem bir_eval_label_exp_lem: + ∀p' p sl le s l. + (∀l'. MEM l' (bir_labels_of_program p') ⇔ + MEM l' (bir_labels_of_program p) ∨ l' = (BL_Label sl)) ⇒ + le ≠ BLE_Label (BL_Label sl) ⇒ + bir_eval_label_exp le s.bst_environ = SOME l ⇒ + (MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) +Proof +REPEAT STRIP_TAC >> +Cases_on ‘le’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_eval_label_exp_def] +) >> +rename1 ‘BLE_Exp e’ >> +FULL_SIMP_TAC std_ss [bir_eval_label_exp_def] >> +Cases_on ‘bir_eval_exp e s.bst_environ’ >- ( + FULL_SIMP_TAC std_ss [] +) >> FULL_SIMP_TAC std_ss [] >> +rename1 ‘_ = SOME v’ >> +Cases_on ‘v’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [] >> + RW_TAC (std_ss++holBACore_ss) [] +) >> +FULL_SIMP_TAC (std_ss++holBACore_ss) [] +QED + +Theorem bir_exec_stmt_jmp_same: + ∀p' p sl le s s'. + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + le ≠ BLE_Label (BL_Label sl) ⇒ + bir_exec_stmt_jmp p' le s = s' ⇒ + bir_exec_stmt_jmp p le s = s' +Proof +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +SIMP_TAC std_ss [bir_exec_stmt_jmp_def] >> + +(*le not well typed*) +Cases_on ‘bir_eval_label_exp le s.bst_environ’ >- ( + ASM_SIMP_TAC std_ss [] +) >> ASM_SIMP_TAC std_ss [] >> + +(*le well typed*) +rename1 ‘_ = SOME l’ >> +subgoal ‘MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)’ >- ( + IMP_RES_TAC bir_eval_label_exp_lem +) >> +PROVE_TAC [bir_exec_stmt_jmp_to_label_same] +QED + +Theorem bir_exec_stmt_cjmp_same: + ∀p' p sl le1 le2 c s s' . + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + le1 ≠ BLE_Label (BL_Label sl) ⇒ + le2 ≠ BLE_Label (BL_Label sl) ⇒ + bir_exec_stmt_cjmp p' c le1 le2 s = s' ⇒ + bir_exec_stmt_cjmp p c le1 le2 s = s' +Proof +RW_TAC std_ss [bir_exec_stmt_cjmp_def] >> + +(*c not well typed*) +Cases_on ‘vobc’ >- ( + ASM_SIMP_TAC std_ss [] +) >> ASM_SIMP_TAC std_ss [] >> + +(*c well typed*) +METIS_TAC [bir_exec_stmt_jmp_same] +QED + +Theorem bir_exec_block_same: + ∀p' p sl bl s s' os m. + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + ~(direct_jump_target_block (BL_Label sl) bl) ⇒ + bir_exec_block p' bl s = (os, m, s') ⇒ + bir_exec_block p bl s = (os, m, s') +Proof +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +rename1 ‘_ = (os', m', s'')’ >> + +(*Execution of basic statements has same result*) +SIMP_TAC std_ss [bir_exec_block_def] >> +‘∃os m s'. bir_exec_stmtsB bl.bb_statements ([], 0, s) = (os, m, s')’ by + PROVE_TAC [pairTheory.PAIR] >> +Q.ABBREV_TAC ‘s2 = bir_exec_stmtE p' bl.bb_last_statement s'’ >> +Q.ABBREV_TAC ‘s1 = bir_exec_stmtE p bl.bb_last_statement s'’ >> +FULL_SIMP_TAC std_ss [LET_DEF] >> + +(*Already terminated after execution of basic statements*) +Cases_on ‘bir_state_is_terminated s'’ >- ( + ASM_SIMP_TAC std_ss [] +) >> ASM_SIMP_TAC std_ss [] >> + +(*Still running after execution of basic statements*) + +(*Last statement is Jmp*) +Cases_on ‘bl.bb_last_statement’ >> +FULL_SIMP_TAC std_ss [bir_exec_stmtE_def] >- ( + rename1 ‘_ = BStmt_Jmp le’ >> + ‘le ≠ BLE_Label (BL_Label sl)’ by ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [direct_jump_target_block_def] + ) >> + METIS_TAC [bir_exec_stmt_jmp_same] +) >> + +(*Last statement is CJmp*) +rename1 ‘_ = BStmt_CJmp c le1 le2’ >> +subgoal ‘le1 ≠ BLE_Label (BL_Label sl) ∧ + le2 ≠ BLE_Label (BL_Label sl)’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [direct_jump_target_block_def] >> + PROVE_TAC [] +) >> +METIS_TAC [bir_exec_stmt_cjmp_same] +QED + + +(*TODO: Simplify long theorem propositions?*) + +Definition jump_fresh_def: + jump_fresh e s s2 sl s1 p = + ∃v. + (bir_eval_exp e s.bst_environ = SOME (BVal_Imm v) ∧ + s.bst_status = BST_Running ∧ + s2 = s with bst_pc := bir_block_pc (BL_Label sl) ∧ + (MEM (BL_Address v) (bir_labels_of_program p) ⇒ + s1 = s with bst_pc := bir_block_pc (BL_Address v))) +End + +Theorem jump_fresh_terminated: + ∀e s s2 sl s1 p. + ~(bir_state_is_terminated s) ⇒ + jump_fresh e s s2 sl s1 p ⇒ + ~(bir_state_is_terminated s2) +Proof +REPEAT GEN_TAC >> +SIMP_TAC (std_ss++holBACore_ss) [jump_fresh_def, bir_state_is_terminated_def] >> +REPEAT STRIP_TAC >> +ASM_SIMP_TAC (std_ss++bir_TYPES_ss) [] +QED + +Theorem bir_exec_stmtE_cjmp_jmp: + ∀p' p sl es1 e c v es2 s s2 s1. + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + MEM (BL_Address v) (bir_labels_of_program p) ⇒ + type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ⇒ + + es1 = BStmt_Jmp (BLE_Exp e) ⇒ + c = BExp_BinPred BIExp_Equal e (BExp_Const v) ⇒ + es2 = BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl)) ⇒ + + s.bst_status = BST_Running ⇒ + bir_exec_stmtE p' es2 s = s2 ⇒ + bir_exec_stmtE p es1 s = s1 ⇒ + (s1 = s2 ∨ jump_fresh e s s2 sl s1 p) +Proof +REPEAT GEN_TAC >> NTAC 3 STRIP_TAC >> +SIMP_TAC (std_ss++holBACore_ss) [bir_exec_stmtE_def, bir_exec_stmt_cjmp_def, LET_DEF] >> +NTAC 3 (DISCH_THEN (K ALL_TAC)) >> +rename1 ‘MEM (BL_Address v') _’ >> + +(*e not well typed*) +Cases_on ‘bir_eval_exp e s.bst_environ’ >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_exec_stmt_jmp_def, bir_eval_label_exp_def] +) >> +REVERSE (Cases_on ‘x’) >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_exec_stmt_jmp_def, bir_eval_label_exp_def] +) >> + +(*e well typed*) +ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> +rename1 ‘_ = SOME (BVal_Imm v)’ >> + +(*e and v must have same type*) +Q.SUBGOAL_THEN ‘type_of_bir_imm v = type_of_bir_imm v'’ + (fn thm => SIMP_TAC (std_ss++holBACore_ss) [thm]) >- ( + MP_TAC (Q.SPECL [‘s.bst_environ’, ‘e’, ‘BType_Imm (type_of_bir_imm v')’] type_of_bir_exp_THM) >> + ASM_SIMP_TAC (std_ss++holBACore_ss) [] +) >> + +(*e = v*) +Cases_on ‘bir_bin_pred BIExp_Equal v v'’ >> +ASM_SIMP_TAC std_ss [] >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) + [bir_bin_pred_Equal_REWR, bir_exec_stmt_jmp_def, + bir_eval_label_exp_def] >> + PROVE_TAC [bir_exec_stmt_jmp_to_label_same] +) >> + +(*e ≠ v*) +FULL_SIMP_TAC (std_ss++holBACore_ss) + [bir_bin_pred_Equal_REWR, bir_exec_stmt_jmp_def, + bir_eval_label_exp_def, bir_exec_stmt_jmp_to_label_def] >> +PROVE_TAC [jump_fresh_def] +QED + +Definition exec_stmtsB_def: + exec_stmtsB bss s = + let (os, m, s') = bir_exec_stmtsB bss ([],0,s) in + s' +End + +(*TODO: Last case in bir_exec_block_cjmp_jmp and resolved_simulated chaosy *) + +Theorem bir_exec_block_cjmp_jmp: + ∀p' p sl bl1 l1 bss e c v bl2 s s2 os2 m2 s1 os1 m1. + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + ~(direct_jump_target_block (BL_Label sl) bl1) ⇒ + MEM (BL_Address v) (bir_labels_of_program p) ⇒ + type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ⇒ + + bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ⇒ + c = BExp_BinPred BIExp_Equal e (BExp_Const v) ⇒ + bl2 = bir_block_t l1 bss + (BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl))) ⇒ + + bir_exec_block p' bl2 s = (os2, m2, s2) ⇒ + bir_exec_block p bl1 s = (os1, m1, s1) ⇒ + (s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ (jump_fresh e (exec_stmtsB bss s) s2 sl s1 p) +Proof +REPEAT GEN_TAC >> NTAC 4 STRIP_TAC >> +rename1 ‘bir_exec_block p' _ _= (os2', m2', s2')’ >> +rename1 ‘bir_exec_block p _ _ = (os1', m1', s1')’ >> + +(*Execution of basic statements has same result*) +SIMP_TAC (std_ss++bir_TYPES_ss) [bir_exec_block_def] >> +NTAC 3 (DISCH_THEN (K ALL_TAC)) >> +‘∃os m s'. bir_exec_stmtsB bss ([], 0, s) = (os, m, s')’ by + PROVE_TAC [pairTheory.PAIR] >> +Q.ABBREV_TAC ‘c = BExp_BinPred BIExp_Equal e (BExp_Const v)’ >> + +Q.ABBREV_TAC ‘s2 = bir_exec_stmtE p' + (BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl))) s'’ >> +Q.ABBREV_TAC ‘s1 = bir_exec_stmtE p (BStmt_Jmp (BLE_Exp e)) s'’ >> +FULL_SIMP_TAC std_ss [LET_DEF] >> + +(*Already terminated after execution of basic statements*) +Cases_on ‘bir_state_is_terminated s'’ >- ( + ASM_SIMP_TAC std_ss [] +) >> ASM_SIMP_TAC std_ss [] >> + +(*Still running after execution of basic statements*) +‘s'.bst_status = BST_Running’ by FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] >> +(*e = v*) +‘s2 = s1 ∨ jump_fresh e s' s2 sl s1 p’ by METIS_TAC [bir_exec_stmtE_cjmp_jmp] >- ( + ASM_SIMP_TAC std_ss [] +) >> + +(*e ≠ v*) +IMP_RES_TAC jump_fresh_terminated >> +POP_ASSUM (fn thm => SIMP_TAC std_ss [thm]) >> +FULL_SIMP_TAC std_ss [jump_fresh_def] >> +Cases_on ‘MEM (BL_Address v') (bir_labels_of_program p)’ >> +FULL_SIMP_TAC std_ss [] >- ( + subgoal ‘~(bir_state_is_terminated s1)’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] + ) >> REV_FULL_SIMP_TAC std_ss [] >> + REPEAT STRIP_TAC >> DISJ2_TAC >> + FULL_SIMP_TAC (std_ss++holBACore_ss) [jump_fresh_def, exec_stmtsB_def, LET_DEF] +) >> + +REPEAT STRIP_TAC >> DISJ2_TAC >> +FULL_SIMP_TAC (std_ss++holBACore_ss) [jump_fresh_def, exec_stmtsB_def, LET_DEF] +QED + + +Theorem bir_exec_block_jmp: + ∀p' p sl s e v bl. + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + ~(bir_state_is_terminated s) ⇒ + bir_eval_exp e s.bst_environ = SOME (BVal_Imm v) ⇒ + bl = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ + (∃s'. bir_exec_block p' bl s = ([], 1, s') ∧ + if MEM (BL_Address v) (bir_labels_of_program p) then + s' = s with bst_pc := bir_block_pc (BL_Address v) + else s'.bst_status = BST_JumpOutside (BL_Address v)) +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (list_ss++holBACore_ss) + [bir_exec_block_def, bir_exec_stmtsB_def, LET_DEF, + bir_exec_stmtE_def, bir_exec_stmt_jmp_def, bir_eval_label_exp_def, + bir_exec_stmt_jmp_to_label_def, bir_state_is_terminated_def] +QED + +Theorem bir_exec_to_labels_jmp: + ∀(p' : 'a bir_program_t) (p : 'a bir_program_t) sl e s v bl ls. + (∀l. MEM l (bir_labels_of_program p') ⇔ + MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ + ~(bir_state_is_terminated s) ⇒ + bir_eval_exp e s.bst_environ = SOME (BVal_Imm v) ⇒ + + bl = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ + bir_get_current_block p' (s.bst_pc) = SOME bl ⇒ + ls = bir_labels_of_program p ⇒ + (∃s' n. bir_exec_to_labels (set ls) p' s = BER_Ended [] 1 n s' ∧ + if MEM (BL_Address v) (bir_labels_of_program p) then + s' = s with bst_pc := bir_block_pc (BL_Address v) + else s'.bst_status = BST_JumpOutside (BL_Address v)) +Proof +REPEAT STRIP_TAC >> +IMP_RES_TAC bir_exec_to_labels_block >> +Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm]) >> +IMP_RES_TAC bir_exec_block_jmp >> +Cases_on ‘MEM (BL_Address v) (bir_labels_of_program p)’ >> +FULL_SIMP_TAC (list_ss++holBACore_ss) + [LET_DEF, bir_state_COUNT_PC_def, bir_state_is_terminated_def, + bir_block_pc_def] >> + +(*v not in labels of p*) +FULL_SIMP_TAC (std_ss++holBACore_ss) + [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED, + bir_block_pc_def] +QED + + +Theorem resolved_simulated_lem: + ∀p s bl os m s' pc_cond ls. + bir_get_current_block p s.bst_pc = SOME bl ⇒ + bir_exec_block p bl s = (os, m, s') ⇒ + s'.bst_status = BST_Running ⇒ + ls = bir_labels_of_program p ⇒ + pc_cond = (F, (λpc. pc.bpc_index = 0 ∧ MEM pc.bpc_label ls)) ⇒ + 0 < m ∧ bir_state_COUNT_PC pc_cond s' +Proof +REPEAT STRIP_TAC >> +‘~(bir_state_is_terminated s')’ by ASM_SIMP_TAC (std_ss++holBACore_ss) [] >- ( + CCONTR_TAC >> + ‘m = 0’ by DECIDE_TAC >> + PROVE_TAC [bir_exec_block_REWR_NO_STEP] +) >> + +ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_state_COUNT_PC_def] >> +‘IS_SOME (bir_get_current_block p s'.bst_pc)’ by PROVE_TAC [bir_exec_block_new_block_pc] >> +‘∃l. s'.bst_pc = bir_block_pc l’ by ( + FULL_SIMP_TAC (std_ss++bir_TYPES_ss) [bir_block_pc_def, bir_get_current_block_def, + optionTheory.IS_SOME_EXISTS, + bir_programcounter_t_component_equality] +) >> POP_ASSUM SUBST_ALL_TAC >> +FULL_SIMP_TAC (std_ss++holBACore_ss) + [bir_block_pc_def, bir_get_current_block_block_pc_IS_SOME] +QED + + +val quantifiers = [‘p'’, ‘p’, ‘sl’, ‘bl1’, ‘l1’, ‘bss’, ‘e’, ‘c’, ‘v’, + ‘bl2’, ‘s’, ‘s2’, ‘os2’, ‘m2’, ‘s1’, ‘os1’, ‘m1’] + + +(*TODO: simplify repetitiveness in cases?*) +Theorem resolved_simulated: + ∀l1 v sl p p'. + resolved l1 v sl p p' ⇒ + simulated p p' +Proof +REPEAT GEN_TAC >> STRIP_TAC >> +SIMP_TAC std_ss [simulated_def, exec_to_prog_def] >> +Q.ABBREV_TAC ‘ls = (bir_labels_of_program p)’ >> +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +rename1 ‘_ = BER_Ended o2' m2' n2' s''’ >> + +(*Same block*) +REVERSE (Cases_on ‘l = l1’) >- ( + ‘∃bl. bir_get_current_block p s.bst_pc = SOME bl ∧ + bir_get_current_block p' s.bst_pc = SOME bl’ by ( + PROVE_TAC [resolved_def_cases] + ) >> + + IMP_RES_TAC bir_exec_to_labels_block >> + NTAC 2 (Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm])) >> + Q.ABBREV_TAC ‘pc_cond = (F, (λpc. pc.bpc_index = 0 ∧ MEM pc.bpc_label ls))’ >> + ‘∃os2 m2 s2. bir_exec_block p' bl s = (os2, m2, s2)’ by PROVE_TAC [pairTheory.PAIR] >> + ‘∃os1 m1 s1. bir_exec_block p bl s = (os1, m1, s1)’ by PROVE_TAC [pairTheory.PAIR] >> + FULL_SIMP_TAC std_ss [LET_DEF] >> + + (*Programs execute block bl with same result*) + Q.SUBGOAL_THEN ‘s2 = s1 ∧ os2 = os1 ∧ m2 = m1’ (fn thm => SIMP_TAC std_ss [thm]) >- ( + MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘sl’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> + FULL_SIMP_TAC std_ss [resolved_def_cases, fresh_label_def, direct_jump_target_def] + ) >> + + (*Programs fail*) + REVERSE (Cases_on ‘s1.bst_status = BST_Running’) >- ( + ‘bir_state_is_terminated s1’ by ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + FULL_SIMP_TAC (std_ss++bir_TYPES_ss) + [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] + ) >> + + (*Programs successfully jump*) + ‘0 < m1 ∧ bir_state_COUNT_PC pc_cond s1’ by ( + METIS_TAC [resolved_simulated_lem] + ) >> ASM_SIMP_TAC (std_ss++holBACore_ss) [] +) >> + +(*Different blocks*) +POP_ASSUM SUBST_ALL_TAC >> +‘∃bl1 bl2 bl3. + bir_get_current_block p s.bst_pc = SOME bl1 ∧ + bir_get_current_block p' s.bst_pc = SOME bl2 ∧ + bir_get_current_block p' (bir_block_pc (BL_Label sl)) = SOME bl3 ∧ + resolved_block l1 v sl bl1 bl2 bl3’ by ( + FULL_SIMP_TAC std_ss [resolved_def_cases] +) >> +FULL_SIMP_TAC std_ss [resolved_block_def_cases] >> +Q.ABBREV_TAC ‘c = BExp_BinPred BIExp_Equal e (BExp_Const v)’ >> + +IMP_RES_TAC bir_exec_to_labels_block >> +NTAC 2 (Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm])) >> +Q.ABBREV_TAC ‘pc_cond = (F, (λpc. pc.bpc_index = 0 ∧ MEM pc.bpc_label ls))’ >> +‘∃os2 m2 s2. bir_exec_block p' bl2 s = (os2, m2, s2)’ by PROVE_TAC [pairTheory.PAIR] >> +‘∃os1 m1 s1. bir_exec_block p bl1 s = (os1, m1, s1)’ by PROVE_TAC [pairTheory.PAIR] >> +FULL_SIMP_TAC std_ss [LET_DEF] >> + +(*e = v*) +subgoal ‘(s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ + jump_fresh e (exec_stmtsB bss s) s2 sl s1 p’ >- ( + MP_TAC (Q.SPECL quantifiers bir_exec_block_cjmp_jmp) >> + FULL_SIMP_TAC std_ss [resolved_def_cases, fresh_label_def, + direct_jump_target_def, resolved_block_def_cases] +) >- ( + (*Programs execute block labelled l1 with same result*) + NTAC 3 (POP_ASSUM (fn thm => SIMP_TAC std_ss [GSYM thm])) >> + + (*Programs fail*) + REVERSE (Cases_on ‘s1.bst_status = BST_Running’) >- ( + ‘bir_state_is_terminated s1’ by ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + FULL_SIMP_TAC (std_ss++bir_TYPES_ss) + [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] + ) >> + + (*Programs successfully jump*) + ‘0 < m1 ∧ bir_state_COUNT_PC pc_cond s1’ by ( + METIS_TAC [resolved_simulated_lem] + ) >> ASM_SIMP_TAC (std_ss++holBACore_ss) [] +) >> + +(*e ≠ v*) +(*Programs execute block l1 with different results: + p tries to jump to e, p' jumps to sl*) +FULL_SIMP_TAC std_ss [jump_fresh_def] >> +Q.PAT_ASSUM ‘s2 = _’ (fn thm => SIMP_TAC std_ss [GSYM thm]) >> + +(*Program p' continues execution*) +Q.SUBGOAL_THEN ‘~(bir_state_COUNT_PC pc_cond s2)’ (fn thm => SIMP_TAC std_ss [thm]) >- ( + Q.UNABBREV_TAC ‘pc_cond’ >> + FULL_SIMP_TAC (std_ss++holBACore_ss) + [bir_state_COUNT_PC_def, jump_fresh_def, + bir_block_pc_def, resolved_def_cases, fresh_label_def] +) >> + +(*Program p' executes block sl and tries to jump to e*) +subgoal ‘∃s2' n. bir_exec_to_labels (set ls) p' s2 = BER_Ended [] 1 n s2' ∧ + if MEM (BL_Address v') (bir_labels_of_program p) then + s2' = s2 with bst_pc := bir_block_pc (BL_Address v') + else s2'.bst_status = BST_JumpOutside (BL_Address v')’ >- ( + MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘sl’, ‘e’, ‘s2’, ‘v'’] bir_exec_to_labels_jmp) >> + FULL_SIMP_TAC (std_ss++holBACore_ss) [resolved_def_cases] +) >> + +(*Evaluation of e in labels of p*) +Cases_on ‘MEM (BL_Address v') (bir_labels_of_program p)’ >> +FULL_SIMP_TAC (list_ss++holBACore_ss) [] >- ( + (*Programs successfully jump to e*) + STRIP_TAC >> POP_ASSUM (fn thm => ASSUME_TAC (GSYM thm)) >> + subgoal ‘0 < m1 ∧ bir_state_COUNT_PC pc_cond s1’ >- ( + MP_TAC (Q.SPECL [‘p’, ‘s’, ‘bl1’, ‘os1’, ‘m1’, ‘s1’] resolved_simulated_lem) >> + ASM_SIMP_TAC (std_ss++holBACore_ss) [] + ) >> + REV_FULL_SIMP_TAC (std_ss++holBACore_ss) [] +) >> + +(*Evaluation of e not in labels of p*) +(*Programs jumps outside to e*) +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (list_ss++holBACore_ss) [] +QED + + +val _ = export_theory(); + From f046c99ad7bbe80f2f7fb1d5e125673a75c94152 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 7 Apr 2021 16:50:52 +0200 Subject: [PATCH 0036/1015] Add program generator variants with a prepended load --- src/tools/scamv/proggen/asm_genLib.sig | 2 ++ src/tools/scamv/proggen/asm_genLib.sml | 21 +++++++++++++++++++++ src/tools/scamv/proggen/bir_prog_genLib.sml | 2 ++ 3 files changed, 25 insertions(+) diff --git a/src/tools/scamv/proggen/asm_genLib.sig b/src/tools/scamv/proggen/asm_genLib.sig index ac14ef0df..4a8b97200 100644 --- a/src/tools/scamv/proggen/asm_genLib.sig +++ b/src/tools/scamv/proggen/asm_genLib.sig @@ -42,6 +42,8 @@ sig val arb_program_spectre_v1 : ArmInstruction list Gen; val arb_program_spectre_v1_mod1 : ArmInstruction list Gen; + val arb_program_spectre_v1_mod2 : ArmInstruction list Gen; + val arb_program_spectre_v1_mod2_dep : ArmInstruction list Gen; val arb_program_straightline_branch : ArmInstruction list Gen; diff --git a/src/tools/scamv/proggen/asm_genLib.sml b/src/tools/scamv/proggen/asm_genLib.sml index 30c1d0170..15f044197 100644 --- a/src/tools/scamv/proggen/asm_genLib.sml +++ b/src/tools/scamv/proggen/asm_genLib.sml @@ -355,11 +355,32 @@ local [Load (Reg reg_y, Ld2 (reg_x, reg_a1))]@ (Portable.the_list (get_next_spectre_v1_mul ()))@ [Load (Reg reg_z, Ld2 (reg_y, reg_a2))])); + + val reg_t1 = "x10"; + val reg_t2 = "x11"; + fun gen_preload with_dep = + let + val (reg_t, reg_s) = + if with_dep then + (reg_la1, reg_t1) + else + (reg_t1, reg_t2); + in + return (Load (Reg reg_t, Ld (NONE, reg_s))) + end; in val arb_program_spectre_v1 = gen_arr_bnds_chck_acc gen_arr_acc; val arb_program_spectre_v1_mod1 = gen_arr_bnds_chck_acc_mod gen_arr_acc (return [Nop]); + + fun arb_program_spectre_v1_mod2_gen w_dep = + gen_preload w_dep >>= (fn preload_instr => + gen_arr_bnds_chck_acc gen_arr_acc >>= (fn gadget_instrs => + return (preload_instr::gadget_instrs) + )); + val arb_program_spectre_v1_mod2 = arb_program_spectre_v1_mod2_gen false; + val arb_program_spectre_v1_mod2_dep = arb_program_spectre_v1_mod2_gen true; end; (* =============== straightline speculation ================= *) diff --git a/src/tools/scamv/proggen/bir_prog_genLib.sml b/src/tools/scamv/proggen/bir_prog_genLib.sml index c031079e6..6fa8b1373 100644 --- a/src/tools/scamv/proggen/bir_prog_genLib.sml +++ b/src/tools/scamv/proggen/bir_prog_genLib.sml @@ -223,6 +223,8 @@ fun pgen_qc_param param = | "xld_br_yld_mod1" => prog_gen_a_la_qc arb_program_xld_br_yld_mod1 | "spectre_v1" => prog_gen_a_la_qc arb_program_spectre_v1 | "spectre_v1_mod1" => prog_gen_a_la_qc arb_program_spectre_v1_mod1 + | "spectre_v1_mod2" => prog_gen_a_la_qc arb_program_spectre_v1_mod2 + | "spectre_v1_mod2_dep" => prog_gen_a_la_qc arb_program_spectre_v1_mod2_dep | "straightline_branch" => prog_gen_a_la_qc arb_program_straightline_branch | _ => raise ERR "prog_gen_store_a_la_qc" "unknown qc generator"; From 49d9c194a9eeaaa26ef9bd6370ee7d90cc3c3127 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 7 Apr 2021 17:19:48 +0200 Subject: [PATCH 0037/1015] Fix --- src/tools/scamv/proggen/asm_genLib.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/scamv/proggen/asm_genLib.sml b/src/tools/scamv/proggen/asm_genLib.sml index 15f044197..6a887344e 100644 --- a/src/tools/scamv/proggen/asm_genLib.sml +++ b/src/tools/scamv/proggen/asm_genLib.sml @@ -376,7 +376,7 @@ in fun arb_program_spectre_v1_mod2_gen w_dep = gen_preload w_dep >>= (fn preload_instr => - gen_arr_bnds_chck_acc gen_arr_acc >>= (fn gadget_instrs => + arb_program_spectre_v1_mod1 >>= (fn gadget_instrs => return (preload_instr::gadget_instrs) )); val arb_program_spectre_v1_mod2 = arb_program_spectre_v1_mod2_gen false; From 02fe02b5bd0c4523516722d5939911a205582100 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Thu, 8 Apr 2021 11:44:43 +0200 Subject: [PATCH 0038/1015] Added cache_straightline observation model --- src/tools/scamv/bir_scamv_driverLib.sml | 2 ++ src/tools/scamv/obsmodel/bir_obs_modelLib.sml | 19 ++++++++++++++++++ .../scamv/obsmodel/bir_obs_modelScript.sml | 20 ++++++++++++++++++- src/tools/scamv/scamv_configLib.sig | 1 + src/tools/scamv/scamv_configLib.sml | 4 +++- 5 files changed, 44 insertions(+), 2 deletions(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index 4e123f456..1644d8152 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -503,6 +503,8 @@ fun match_obs_model obs_model = "cache_speculation" | cache_speculation_first => "cache_speculation_first" + | cache_straightline => + "cache_straightline" | cache_tag_index_part_page => "cache_tag_index_part_page" | _ => raise ERR "match_obs_model" ("unknown obs_model " ^ PolyML.makestring obs_model); diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml index f437e0dc4..5016ab0f4 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml @@ -299,6 +299,9 @@ open bir_cfgLib; prog targets end + + fun jmp_to_cjmp t = (rand o concl) (EVAL “jmp_to_cjmp_prog ^t”); + in (* Exmaple usage: inputs are lifted program with intial observation and depth of execution *) @@ -320,6 +323,18 @@ in branch_instrumentation obs_all_refined_but_first (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; end; + structure bir_arm8_cache_straight_line_model : OBS_MODEL = + struct + val obs_hol_type = ``bir_val_t``; + val pipeline_depth = 3; + fun add_obs mb t = + let val obs_term = bir_arm8_mem_addr_pc_model.add_obs mb t; + val jmp_to_cjmp_term = jmp_to_cjmp obs_term; + in + branch_instrumentation obs_all_refined jmp_to_cjmp_term pipeline_depth + end; + end; + end (* local *) @@ -342,6 +357,8 @@ fun get_obs_model id = bir_arm8_cache_speculation_model.obs_hol_type else if id = "cache_speculation_first" then bir_arm8_cache_speculation_first_model.obs_hol_type + else if id = "cache_straightline" then + bir_arm8_cache_straight_line_model.obs_hol_type else raise ERR "get_obs_model" ("unknown obs_model selected: " ^ id); @@ -362,6 +379,8 @@ fun get_obs_model id = bir_arm8_cache_speculation_model.add_obs else if id = "cache_speculation_first" then bir_arm8_cache_speculation_first_model.add_obs + else if id = "cache_straightline" then + bir_arm8_cache_straight_line_model.add_obs else raise ERR "get_obs_model" ("unknown obs_model selected: " ^ id); in diff --git a/src/tools/scamv/obsmodel/bir_obs_modelScript.sml b/src/tools/scamv/obsmodel/bir_obs_modelScript.sml index a52af822e..e2d840cb1 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelScript.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelScript.sml @@ -51,6 +51,25 @@ val add_obs_constr_mem_block_def = Define` `; +val map_end_prog_def = Define‘ + map_end_prog f [] = [] +/\ map_end_prog f [b] = [b] +/\ map_end_prog f (b::next_b::bs) = + (b with <| bb_last_statement updated_by (f (next_b.bb_label)) |>):: map_end_prog f (next_b::bs) +’; + +val jmp_to_cjmp_def = Define‘ + (jmp_to_cjmp next_lbl (BStmt_Jmp target) = + if target <> (BLE_Label next_lbl) + then BStmt_CJmp (BExp_Const (Imm1 1w)) target (BLE_Label next_lbl) + else BStmt_Jmp target) + /\ jmp_to_cjmp next_lbl stmt = stmt +’; + +val jmp_to_cjmp_prog_def = Define‘ + jmp_to_cjmp_prog (BirProgram xs) = BirProgram (map_end_prog jmp_to_cjmp xs) +’; + (* observe pc *) (* ============================================================================== *) val observe_label_def = Define ` @@ -71,7 +90,6 @@ val add_obs_pc_def = Define` add_obs_pc p = map_obs_prog add_obs_pc_block p `; - (* observe whole memory address *) (* ============================================================================== *) val observe_mem_addr_def = Define` diff --git a/src/tools/scamv/scamv_configLib.sig b/src/tools/scamv/scamv_configLib.sig index d219351dc..2c7ce679b 100644 --- a/src/tools/scamv/scamv_configLib.sig +++ b/src/tools/scamv/scamv_configLib.sig @@ -16,6 +16,7 @@ sig | cache_tag_index_part_page | cache_speculation | cache_speculation_first + | cache_straightline datatype hw_obs_model = hw_cache_tag_index | hw_cache_index_numvalid diff --git a/src/tools/scamv/scamv_configLib.sml b/src/tools/scamv/scamv_configLib.sml index 2bf51cf6d..55d99ed0c 100644 --- a/src/tools/scamv/scamv_configLib.sml +++ b/src/tools/scamv/scamv_configLib.sml @@ -27,6 +27,7 @@ datatype obs_model = mem_address_pc | cache_tag_index_part_page | cache_speculation | cache_speculation_first + | cache_straightline datatype hw_obs_model = hw_cache_tag_index | hw_cache_index_numvalid @@ -87,6 +88,7 @@ fun obs_model_fromString om = | "cache_tag_index_part_page" => SOME cache_tag_index_part_page | "cache_speculation" => SOME cache_speculation | "cache_speculation_first" => SOME cache_speculation_first + | "cache_straightline" => SOME cache_straightline | _ => NONE fun hw_obs_model_fromString hwom = @@ -436,7 +438,7 @@ fun print_scamv_opt_usage () = print "Scam-V Usage:\n\n"; List.map print_entry opt_table; print ("\ngenerator arg should be one of: rand, prefetch_strides, qc, slice, file, list\n"); - print ("\nobs_model arg should be one of: mem_address_pc, cache_tag_index, cache_tag_only, cache_index_only, cache_tag_index_part, cache_tag_index_part_page, cache_speculation\n"); + print ("\nobs_model arg should be one of: mem_address_pc, cache_tag_index, cache_tag_only, cache_index_only, cache_tag_index_part, cache_tag_index_part_page, cache_speculation, cache_speculation_first, cache_straightline\n"); print ("\nrefined_obs_model arg is like obs_model\n"); print ("\nobs_projection is an observation id as a number\n"); print ("\nhw_obs_model arg should be one of: hw_cache_tag_index, hw_cache_index_numvalid, hw_cache_tag_index_part, hw_cache_tag_index_part_page\n"); From 18f037189b1792738342a72ea6fa81adb3effffa Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Fri, 9 Apr 2021 11:04:06 +0200 Subject: [PATCH 0039/1015] Add preliminary contract transfer theorem depending on two unproven lemmas (#2) * Add definition of multistep simulation (simulated_n_def) and refinement theorem (simulated_simulated_n) * Change definition of contract simulation (simulated_contract_def) * Add refinement theorem for contract simulation (simulated_simulated_contract) depending on two unproven lemmas about bir_exec_to_labels * Add preliminary contract transfer theorem proved using theory above --- examples/ijr/contractTransferScript.sml | 218 ++++++++++++++++++++++-- examples/ijr/simulationScript.sml | 3 +- 2 files changed, 203 insertions(+), 18 deletions(-) diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index 56c374e1d..d2964615a 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -1,54 +1,238 @@ open HolKernel Parse boolLib bossLib; -open bir_programTheory bir_htTheory; +open listTheory; + +open bir_programTheory bir_htTheory bir_program_multistep_propsTheory; open HolBACoreSimps; +open resolutionTheory simulationTheory; + val _ = new_theory "contractTransfer"; -Definition contract_simulated_def: - contract_simulated p p' = - ∀s l ls s' o2 m2 n2. +Definition exec_to_prog_n_def: + exec_to_prog_n p s pls n = + bir_exec_to_labels_n (set (bir_labels_of_program pls)) p s n +End + +(*TODO: Strenthen simulation definitions wrt observations and steps?*) +Definition simulated_n_def: + simulated_n p p' = + ∀n s l s' os2 m2 n2. s.bst_pc = bir_block_pc l ⇒ MEM l (bir_labels_of_program p) ⇒ - (∀l'. l' IN ls ⇒ MEM l' (bir_labels_of_program p)) ⇒ - bir_exec_to_labels ls p' s = BER_Ended o2 m2 n2 s' ⇒ + exec_to_prog_n p' s p n = BER_Ended os2 m2 n2 s' ⇒ ~(∃l'. s'.bst_status = BST_JumpOutside l') ⇒ - (∃o1 m1 n1. - bir_exec_to_labels ls p s = BER_Ended o1 m1 n1 s') + (∃os1 m1 n1. + exec_to_prog_n p s p n = BER_Ended os1 m1 n1 s') End +Theorem simulated_simulated_n: + ∀p p'. simulated p p' ⇒ simulated_n p p' +Proof +REPEAT STRIP_TAC >> +SIMP_TAC std_ss [simulated_n_def, exec_to_prog_n_def] >> +Q.ABBREV_TAC ‘ls = bir_labels_of_program p’ >> + +Induct_on ‘n’ >- ( + SIMP_TAC (std_ss++holBACore_ss) [bir_exec_to_labels_n_REWR_0] +) >> + +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +SIMP_TAC (std_ss++holBACore_ss) [bir_exec_to_labels_n_REWR_SUC] >> + +(*Program p' takes a step*) +Cases_on ‘bir_exec_to_labels (set ls) p' s’ >> +SIMP_TAC (std_ss++holBACore_ss) [] >> +rename1 ‘_ = BER_Ended os21 m21 n21 s2’ >> + +(*There is a contradiction or p takes the same step*) +Cases_on ‘(∃l'. s2.bst_status = BST_JumpOutside l')’ >- ( + FULL_SIMP_TAC (list_ss++holBACore_ss) [bir_state_is_terminated_def, + bir_exec_to_labels_n_REWR_TERMINATED] >> + STRIP_TAC >> FULL_SIMP_TAC (std_ss++holBACore_ss) [] +) >> +subgoal ‘(∃os11 m11 n11. + bir_exec_to_labels (set ls) p s = BER_Ended os11 m11 n11 s2)’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [simulated_def, exec_to_prog_def] +) >> +ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + +(*If programs are terminated, rest of steps are same (needed to use induction hypothesis)*) +Cases_on ‘(bir_state_is_terminated s2)’ >- ( + FULL_SIMP_TAC (list_ss++holBACore_ss) [bir_state_is_terminated_def, + bir_exec_to_labels_n_REWR_TERMINATED] +) >> + +(*Program p' takes the rest of the steps*) +Cases_on ‘bir_exec_to_labels_n (set ls) p' s2 n’ >> +SIMP_TAC (std_ss++holBACore_ss) [] >> +rename1 ‘_ = BER_Ended os22 m22 n22 s2'’ >> +NTAC 2 STRIP_TAC >> + +(*Program p takes the same rest of steps*) +subgoal ‘∃os12 m12 n12. + bir_exec_to_labels_n (set ls) p s2 n = BER_Ended os12 m12 n12 s2'’ >- ( + subgoal ‘∃l'. s2.bst_pc = bir_block_pc l' ∧ MEM l' ls’ >- ( + MP_TAC (Q.SPECL [‘set ls’, ‘p'’, ‘s’, ‘os21’, ‘1’, ‘m21’, ‘n21’, ‘s2’] + bir_exec_to_labels_n_ended_running) >> + FULL_SIMP_TAC (std_ss++holBACore_ss) + [bir_block_pc_def, bir_exec_to_labels_def, + bir_programcounter_t_component_equality] + ) >> + FULL_SIMP_TAC (std_ss++holBACore_ss) [exec_to_prog_n_def] +) >> +ASM_SIMP_TAC (std_ss++holBACore_ss) [] +QED + +Theorem bir_exec_to_labels_expand_labels: + ∀ls ls' p s s' os c1 c2. + ls SUBSET ls' ⇒ + bir_exec_to_labels ls p s = BER_Ended os c1 c2 s' ⇒ + (∃n c2'. + n > 0 ∧ + bir_exec_to_labels_n ls' p s n = BER_Ended os c1 c2' s' ∧ + (∀n'. 0 < n' ∧ n' < n ⇒ + ∃s'' os' c1' c2''. + bir_exec_to_labels_n ls' p s n' = BER_Ended os' c1' c2'' s'' ∧ + ~(s''.bst_pc.bpc_label IN ls))) +Proof +cheat +QED + +Theorem bir_exec_to_labels_restrict_labels: + ∀ls ls' n p s s' os c1 c2. + ls SUBSET ls' ⇒ + n > 0 ⇒ + bir_exec_to_labels_n ls' p s n = BER_Ended os c1 c2 s' ⇒ + s'.bst_pc.bpc_label IN ls ⇒ + (∀n'. 0 < n' ∧ n' < n ⇒ + ∃s'' os' c1' c2''. + bir_exec_to_labels_n ls' p s n' = BER_Ended os' c1' c2'' s'' ∧ + ~(s''.bst_pc.bpc_label IN ls)) ⇒ + (∃c2'. bir_exec_to_labels ls p s = BER_Ended os c1 c2' s') +Proof +cheat +QED + +Definition simulated_contract_def: + simulated_contract p p' = + ∀s l ls s' os2 m2 n2. + s.bst_pc = bir_block_pc l ⇒ + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels ls p' s = BER_Ended os2 m2 n2 s' ⇒ + ~(bir_state_is_terminated s') ⇒ + (∃os1 m1 n1. + bir_exec_to_labels ls p s = BER_Ended os1 m1 n1 s') +End + +Theorem simulated_simulated_contract: + ∀p p'. simulated p p' ⇒ simulated_contract p p' +Proof +REPEAT STRIP_TAC >> +SIMP_TAC std_ss [simulated_contract_def, exec_to_prog_n_def] >> +Q.ABBREV_TAC ‘pls = bir_labels_of_program p’ >> + +(*Expand label set*) +REPEAT STRIP_TAC >> +MP_TAC (Q.SPECL [‘ls’, ‘set pls’, ‘p'’, ‘s’, ‘s'’, ‘os2’, ‘m2’, ‘n2’] + bir_exec_to_labels_expand_labels) >> +ASM_SIMP_TAC std_ss [] >> STRIP_TAC >> +rename1 ‘_ = BER_Ended _ _ n2' _’ >> + +(*Use simulation hypothesis*) +subgoal ‘∃os1 m1 n1. bir_exec_to_labels_n (set pls) p s n = + BER_Ended os1 m1 n1 s'’ >- ( + subgoal ‘~(∃l'. s'.bst_status = BST_JumpOutside l')’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] + ) >> + METIS_TAC [simulated_simulated_n, simulated_n_def, exec_to_prog_n_def] +) >> + +(*Restrict label set*) +subgoal ‘∃n1'.bir_exec_to_labels ls p s = BER_Ended os1 m1 n1' s'’ >- ( + IRULE_TAC bir_exec_to_labels_restrict_labels >> + CONJ_TAC >- ( + ‘(1:num) > 0’ by SIMP_TAC arith_ss [] >> + METIS_TAC [bir_exec_to_labels_def, bir_exec_to_labels_n_ended_running] + ) >> + + Q.LIST_EXISTS_TAC [‘n1’, ‘set pls’, ‘n’] >> CONJ_TAC >- ( + REPEAT STRIP_TAC >> + Q.PAT_X_ASSUM ‘∀n'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘n'’ thm)) >> + REV_FULL_SIMP_TAC std_ss [] >> + + subgoal ‘~(∃l'. s''.bst_status = BST_JumpOutside l')’ >- ( + FULL_SIMP_TAC std_ss [bir_exec_to_labels_n_def] >> + ‘~bir_state_is_terminated s''’ by + IMP_RES_TAC bir_exec_steps_GEN_decrease_max_steps_Ended_terminated >> + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] + ) >> + subgoal ‘∃os' c1' c2''. bir_exec_to_labels_n (set pls) p s n' = + BER_Ended os' c1' c2'' s''’ >- ( + METIS_TAC [simulated_simulated_n, simulated_n_def, exec_to_prog_n_def] + ) >> + + PROVE_TAC [] + ) >> + + ASM_SIMP_TAC std_ss [] +) >> +PROVE_TAC [] +QED + Theorem contract_transfer: - ∀ (p' : 'a bir_program_t) l ls pre post (p : 'a bir_program_t). - contract_simulated p p' ⇒ + ∀ p p' l ls pre post. + simulated p p' ⇒ bir_vars_of_program p' = bir_vars_of_program p ⇒ MEM l (bir_labels_of_program p) ⇒ - (∀l'. l' IN ls ⇒ MEM l' (bir_labels_of_program p)) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ bir_exec_to_labels_triple p' l ls pre post ⇒ bir_exec_to_labels_triple p l ls pre post Proof SIMP_TAC std_ss [bir_exec_to_labels_triple_def] >> REPEAT STRIP_TAC >> + +Q.PAT_X_ASSUM ‘simulated p p'’ + (fn thm => ASSUME_TAC (MATCH_MP simulated_simulated_contract thm)) >> + Q.PAT_X_ASSUM ‘∀s'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘s’ thm)) >> REV_FULL_SIMP_TAC std_ss [] >> rename1 ‘_ = BER_Ended o2 m2 n2 s'’ >> -subgoal ‘∃s1 o1 m1 n1. - bir_exec_to_labels ls p s = BER_Ended o1 m1 n1 s'’ >- ( +subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = + BER_Ended o1 m1 n1 s'’ >- ( ‘s.bst_pc = bir_block_pc l’ by ( ASM_SIMP_TAC (std_ss++holBACore_ss) - [bir_block_pc_def, bir_programcounter_t_component_equality] + [bir_block_pc_def, + bir_programcounter_t_component_equality] ) >> - ‘~(∃l'. s'.bst_status = BST_JumpOutside l')’ by - ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> - METIS_TAC [contract_simulated_def] + ‘~(bir_state_is_terminated s')’ by ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + METIS_TAC [simulated_contract_def] ) >> PROVE_TAC [] QED +(*Sanity check*) +Theorem resolved_contract_transfer: + ∀l1 v sl p p' l ls pre post. + resolved l1 v sl p p' ⇒ + bir_vars_of_program p' = bir_vars_of_program p ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels_triple p' l ls pre post ⇒ + bir_exec_to_labels_triple p l ls pre post +Proof +PROVE_TAC [contract_transfer, resolved_simulated] +QED + val _ = export_theory(); diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml index 47e0ef159..370ba73bd 100644 --- a/examples/ijr/simulationScript.sml +++ b/examples/ijr/simulationScript.sml @@ -17,10 +17,11 @@ Definition exec_to_prog_def: End Definition simulated_def: - simulated p p' = + simulated (p: 'a bir_program_t) (p': 'a bir_program_t) = ∀s l s' o2 m2 n2. s.bst_pc = bir_block_pc l ⇒ MEM l (bir_labels_of_program p) ⇒ + exec_to_prog p' s p = BER_Ended o2 m2 n2 s' ⇒ ~(∃l'. s'.bst_status = BST_JumpOutside l') ⇒ (∃o1 m1 n1. From 9e1c80d310faa2d4de06620f0fc10d0cdf763c5e Mon Sep 17 00:00:00 2001 From: Hamed Date: Sat, 10 Apr 2021 15:58:43 +0200 Subject: [PATCH 0040/1015] fixed the strightline generator --- src/tools/scamv/proggen/asm_genLib.sml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/tools/scamv/proggen/asm_genLib.sml b/src/tools/scamv/proggen/asm_genLib.sml index 6a887344e..083f9e95e 100644 --- a/src/tools/scamv/proggen/asm_genLib.sml +++ b/src/tools/scamv/proggen/asm_genLib.sml @@ -395,15 +395,19 @@ val arb_program_nobranch_nocmp = arb_list_of arb_instruction_nobranch_nocmp; fun arb_program_straightline_cond arb_prog_left arb_prog_right = let fun rel_jmp_after bl = Imm (((length bl) + 1) * 4); - + val arb_load_instr = arb_load_indir; + val arb_prog = arb_prog_left >>= (fn blockl => - arb_prog_right >>= (fn blockr => + arb_prog_right >>= (fn blockr => + arb_load_instr >>= (fn fld => let val blockl_wexit = blockl@[Branch (NONE, rel_jmp_after blockr)] in return ( blockl_wexit - @blockr) + @blockr + @[fld] + ) end - )); + ))); in arb_prog end; @@ -422,7 +426,6 @@ val arb_program_straightline_branch = let val arb_block_3ld = (List.foldr (op@) []) <$> ( sequence [return [ld1] - ,arb_pad ,arb_pad ]) in two (arb_pad) arb_block_3ld From 7da59a8e6a55316ee028e9ff660ebf1214d76a66 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Mon, 12 Apr 2021 13:00:32 +0200 Subject: [PATCH 0041/1015] Add definitions of ijr fail case and corresponding simulation, and simulation theorem for ijr fail case (#3) * Add definition of ijr fail case (resolved_fail_def) * Add definition of corresponding simulation (simulated_fail_def) * Change bir_exec_block_same lemma to be more general * Add simulation theorem for ijr fail case (resolved_fail_simulated_fail) --- examples/ijr/resolutionScript.sml | 23 +++++ examples/ijr/simulationFailScript.sml | 126 ++++++++++++++++++++++++++ examples/ijr/simulationScript.sml | 65 +++++++------ 3 files changed, 187 insertions(+), 27 deletions(-) create mode 100644 examples/ijr/simulationFailScript.sml diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index 4405fc1ac..1d13298f0 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -63,5 +63,28 @@ Inductive resolved_def: End +Inductive resolved_fail_block_def: + ∀l v bl1 bl2 e. + bl1 = bir_block_t l [] (BStmt_Jmp (BLE_Exp e)) ∧ + bl2 = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ + resolved_fail_block l v bl1 bl2 +End + +Inductive resolved_fail_def: + ∀l1 v p p' bl1 bl2. + (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) ∧ + + bir_get_current_block p (bir_block_pc l1) = SOME bl1 ∧ + bir_get_current_block p' (bir_block_pc l1) = SOME bl2 ∧ + resolved_fail_block l1 v bl1 bl2 ∧ + + (∀l. MEM l (bir_labels_of_program p) ∧ l ≠ l1 ⇒ + ∃bl. bir_get_current_block p (bir_block_pc l) = SOME bl ∧ + bir_get_current_block p' (bir_block_pc l) = SOME bl) ⇒ + + resolved_fail l1 v p p' +End + + val _ = export_theory(); diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml new file mode 100644 index 000000000..dc122932a --- /dev/null +++ b/examples/ijr/simulationFailScript.sml @@ -0,0 +1,126 @@ +open HolKernel Parse boolLib bossLib; + +open listTheory pred_setSimps; + +open bir_programTheory bir_expTheory bir_exp_immTheory bir_typing_expTheory; +open bir_valuesTheory bir_auxiliaryTheory +open bir_program_blocksTheory bir_program_multistep_propsTheory; +open HolBACoreSimps; + +open resolutionTheory simulationTheory; + +val _ = new_theory "simulationFail"; + + +Definition simulated_fail_def: + simulated_fail (p: 'a bir_program_t) (p': 'a bir_program_t) = + ∀s l s' o2 m2 n2. + s.bst_pc = bir_block_pc l ⇒ + MEM l (bir_labels_of_program p) ⇒ + + exec_to_prog p' s p = BER_Ended o2 m2 n2 s' ⇒ + ~(s'.bst_status = BST_AssertionViolated) ⇒ + (∃o1 m1 n1. + exec_to_prog p s p = BER_Ended o1 m1 n1 s') +End + +Theorem bir_exec_block_assert: + ∀p l v s bl. + ~(bir_state_is_terminated s) ⇒ + bl = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ + (∃s'. bir_exec_block p bl s = ([], 1, s') ∧ + s'.bst_status = BST_AssertionViolated) +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (list_ss++wordsLib.WORD_ss++holBACore_ss) + [bir_exec_block_def, bir_exec_stmtsB_def, + bir_exec_stmtB_def, bir_exec_stmt_assert_def, + bir_dest_bool_val_def, LET_DEF, OPT_CONS_REWRS] +QED + +Theorem bir_exec_to_labels_assert: + ∀l v ls p s bl. + ~(bir_state_is_terminated s) ⇒ + bl = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ + bir_get_current_block p (s.bst_pc) = SOME bl ⇒ + (∃s'. bir_exec_to_labels ls p s = BER_Ended [] 1 0 s' ∧ + s'.bst_status = BST_AssertionViolated) +Proof +REPEAT STRIP_TAC >> +IMP_RES_TAC bir_exec_to_labels_block >> +Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm]) >> +IMP_RES_TAC bir_exec_block_assert >> +Q.PAT_X_ASSUM `∀p. _` (fn thm => ASSUME_TAC (Q.SPEC `p` thm)) >> +FULL_SIMP_TAC std_ss [LET_DEF] >> +FULL_SIMP_TAC (list_ss++holBACore_ss) [LET_DEF, bir_state_COUNT_PC_def, + bir_exec_to_labels_def, + bir_exec_to_labels_n_REWR_TERMINATED] +QED + +Theorem resolved_fail_simulated_fail: + ∀l1 v p p'. + resolved_fail l1 v p p' ⇒ + simulated_fail p p' +Proof +REPEAT GEN_TAC >> STRIP_TAC >> +SIMP_TAC std_ss [simulated_fail_def, exec_to_prog_def] >> +Q.ABBREV_TAC ‘ls = (bir_labels_of_program p)’ >> +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +rename1 ‘_ = BER_Ended o2' m2' n2' s''’ >> + +(*Same block*) +REVERSE (Cases_on ‘l = l1’) >- ( + ‘∃bl. bir_get_current_block p s.bst_pc = SOME bl ∧ + bir_get_current_block p' s.bst_pc = SOME bl’ by ( + PROVE_TAC [resolved_fail_def_cases] + ) >> + + IMP_RES_TAC bir_exec_to_labels_block >> + NTAC 2 (Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm])) >> + Q.ABBREV_TAC ‘pc_cond = (F, (λpc. pc.bpc_index = 0 ∧ MEM pc.bpc_label ls))’ >> + ‘∃os2 m2 s2. bir_exec_block p' bl s = (os2, m2, s2)’ by PROVE_TAC [pairTheory.PAIR] >> + ‘∃os1 m1 s1. bir_exec_block p bl s = (os1, m1, s1)’ by PROVE_TAC [pairTheory.PAIR] >> + FULL_SIMP_TAC std_ss [LET_DEF] >> + + (*Programs execute block bl with same result*) + Q.SUBGOAL_THEN ‘s2 = s1 ∧ os2 = os1 ∧ m2 = m1’ (fn thm => SIMP_TAC std_ss [thm]) >- ( + MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘{}’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> + FULL_SIMP_TAC (std_ss++PRED_SET_ss) [resolved_fail_def_cases] + ) >> + + (*Programs fail*) + REVERSE (Cases_on ‘s1.bst_status = BST_Running’) >- ( + ‘bir_state_is_terminated s1’ by ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + FULL_SIMP_TAC (std_ss++bir_TYPES_ss) + [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] + ) >> + + (*Programs successfully jump*) + ‘0 < m1 ∧ bir_state_COUNT_PC pc_cond s1’ by ( + METIS_TAC [resolved_simulated_lem] + ) >> ASM_SIMP_TAC (std_ss++holBACore_ss) [] +) >> + +(*Different blocks*) +POP_ASSUM SUBST_ALL_TAC >> +‘∃bl1 bl2. + bir_get_current_block p s.bst_pc = SOME bl1 ∧ + bir_get_current_block p' s.bst_pc = SOME bl2 ∧ + resolved_fail_block l1 v bl1 bl2’ by ( + FULL_SIMP_TAC std_ss [resolved_fail_def_cases] +) >> +FULL_SIMP_TAC std_ss [resolved_fail_block_def_cases] >> + +Cases_on ‘bir_state_is_terminated s’ >- ( + FULL_SIMP_TAC (std_ss++bir_TYPES_ss) + [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] +) >> +IMP_RES_TAC bir_exec_to_labels_assert >> +POP_ASSUM (fn thm => ASSUME_TAC (Q.SPEC ‘set ls’ thm)) >> +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (std_ss++holBACore_ss) [] +QED + + +val _ = export_theory(); + diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml index 370ba73bd..21ce32500 100644 --- a/examples/ijr/simulationScript.sml +++ b/examples/ijr/simulationScript.sml @@ -1,6 +1,6 @@ open HolKernel Parse boolLib bossLib; -open listTheory; +open listTheory pred_setSimps; open bir_programTheory bir_expTheory bir_exp_immTheory bir_typing_expTheory; open bir_program_blocksTheory bir_program_multistep_propsTheory; @@ -39,16 +39,18 @@ SIMP_TAC std_ss [bir_exec_stmt_jmp_to_label_def] QED Theorem bir_eval_label_exp_lem: - ∀p' p sl le s l. + ∀p' p sls le s l. (∀l'. MEM l' (bir_labels_of_program p') ⇔ - MEM l' (bir_labels_of_program p) ∨ l' = (BL_Label sl)) ⇒ - le ≠ BLE_Label (BL_Label sl) ⇒ + MEM l' (bir_labels_of_program p) ∨ + (∃sl. l' = BL_Label sl ∧ sl IN sls)) ⇒ + ~(∃sl. sl IN sls ∧ le = BLE_Label (BL_Label sl)) ⇒ bir_eval_label_exp le s.bst_environ = SOME l ⇒ (MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) Proof REPEAT STRIP_TAC >> Cases_on ‘le’ >- ( - FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_eval_label_exp_def] + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_eval_label_exp_def] >> + PROVE_TAC [] ) >> rename1 ‘BLE_Exp e’ >> FULL_SIMP_TAC std_ss [bir_eval_label_exp_def] >> @@ -64,10 +66,11 @@ FULL_SIMP_TAC (std_ss++holBACore_ss) [] QED Theorem bir_exec_stmt_jmp_same: - ∀p' p sl le s s'. - (∀l. MEM l (bir_labels_of_program p') ⇔ - MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ - le ≠ BLE_Label (BL_Label sl) ⇒ + ∀p' p sls le s s'. + (∀l'. MEM l' (bir_labels_of_program p') ⇔ + MEM l' (bir_labels_of_program p) ∨ + (∃sl. l' = BL_Label sl ∧ sl IN sls)) ⇒ + ~(∃sl. sl IN sls ∧ le = BLE_Label (BL_Label sl)) ⇒ bir_exec_stmt_jmp p' le s = s' ⇒ bir_exec_stmt_jmp p le s = s' Proof @@ -88,11 +91,12 @@ PROVE_TAC [bir_exec_stmt_jmp_to_label_same] QED Theorem bir_exec_stmt_cjmp_same: - ∀p' p sl le1 le2 c s s' . - (∀l. MEM l (bir_labels_of_program p') ⇔ - MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ - le1 ≠ BLE_Label (BL_Label sl) ⇒ - le2 ≠ BLE_Label (BL_Label sl) ⇒ + ∀p' p sls le1 le2 c s s' . + (∀l'. MEM l' (bir_labels_of_program p') ⇔ + MEM l' (bir_labels_of_program p) ∨ + (∃sl. l' = BL_Label sl ∧ sl IN sls)) ⇒ + ~(∃sl. sl IN sls ∧ le1 = BLE_Label (BL_Label sl)) ⇒ + ~(∃sl. sl IN sls ∧ le2 = BLE_Label (BL_Label sl)) ⇒ bir_exec_stmt_cjmp p' c le1 le2 s = s' ⇒ bir_exec_stmt_cjmp p c le1 le2 s = s' Proof @@ -104,14 +108,17 @@ Cases_on ‘vobc’ >- ( ) >> ASM_SIMP_TAC std_ss [] >> (*c well typed*) -METIS_TAC [bir_exec_stmt_jmp_same] +RW_TAC std_ss [] >> +IMP_RES_TAC bir_exec_stmt_jmp_same >> +PROVE_TAC [] QED Theorem bir_exec_block_same: - ∀p' p sl bl s s' os m. - (∀l. MEM l (bir_labels_of_program p') ⇔ - MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ - ~(direct_jump_target_block (BL_Label sl) bl) ⇒ + ∀p' p sls bl s s' os m. + (∀l'. MEM l' (bir_labels_of_program p') ⇔ + MEM l' (bir_labels_of_program p) ∨ + (∃sl. l' = BL_Label sl ∧ sl IN sls)) ⇒ + (∀sl. sl IN sls ⇒ ~direct_jump_target_block (BL_Label sl) bl) ⇒ bir_exec_block p' bl s = (os, m, s') ⇒ bir_exec_block p bl s = (os, m, s') Proof @@ -137,20 +144,23 @@ Cases_on ‘bir_state_is_terminated s'’ >- ( Cases_on ‘bl.bb_last_statement’ >> FULL_SIMP_TAC std_ss [bir_exec_stmtE_def] >- ( rename1 ‘_ = BStmt_Jmp le’ >> - ‘le ≠ BLE_Label (BL_Label sl)’ by ( - FULL_SIMP_TAC (std_ss++holBACore_ss) [direct_jump_target_block_def] + subgoal ‘~(∃sl. sl IN sls ∧ le = BLE_Label (BL_Label sl))’ >- ( + FULL_SIMP_TAC (std_ss++holBACore_ss) [direct_jump_target_block_def] >> + PROVE_TAC [] ) >> - METIS_TAC [bir_exec_stmt_jmp_same] + IMP_RES_TAC bir_exec_stmt_jmp_same >> + PROVE_TAC [] ) >> (*Last statement is CJmp*) rename1 ‘_ = BStmt_CJmp c le1 le2’ >> -subgoal ‘le1 ≠ BLE_Label (BL_Label sl) ∧ - le2 ≠ BLE_Label (BL_Label sl)’ >- ( +subgoal ‘~(∃sl. sl IN sls ∧ le1 = BLE_Label (BL_Label sl)) ∧ + ~(∃sl. sl IN sls ∧ le2 = BLE_Label (BL_Label sl))’ >- ( FULL_SIMP_TAC (std_ss++holBACore_ss) [direct_jump_target_block_def] >> PROVE_TAC [] ) >> -METIS_TAC [bir_exec_stmt_cjmp_same] +IMP_RES_TAC bir_exec_stmt_cjmp_same >> +PROVE_TAC [] QED @@ -415,8 +425,9 @@ REVERSE (Cases_on ‘l = l1’) >- ( (*Programs execute block bl with same result*) Q.SUBGOAL_THEN ‘s2 = s1 ∧ os2 = os1 ∧ m2 = m1’ (fn thm => SIMP_TAC std_ss [thm]) >- ( - MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘sl’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> - FULL_SIMP_TAC std_ss [resolved_def_cases, fresh_label_def, direct_jump_target_def] + MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘{sl}’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> + FULL_SIMP_TAC (std_ss++PRED_SET_ss) + [resolved_def_cases, fresh_label_def, direct_jump_target_def] ) >> (*Programs fail*) From 1e12eb35cb365daaca3faee650ae7e8442ac7855 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Mon, 12 Apr 2021 17:21:09 +0200 Subject: [PATCH 0042/1015] Generalise contract transfer theorem (#4) * Add more general definition of simulation (simulated_termination_def) * Add refinement theorems (simulated_simulated_termination and simulated_fail_simulated_termination) * Generalise contract refinement theorem, multistep simulation and refinement theorem and contract transfer theorem --- examples/ijr/contractTransferScript.sml | 105 ++++++++++++++++-------- 1 file changed, 72 insertions(+), 33 deletions(-) diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index d2964615a..53b847528 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -5,34 +5,62 @@ open listTheory; open bir_programTheory bir_htTheory bir_program_multistep_propsTheory; open HolBACoreSimps; -open resolutionTheory simulationTheory; +open resolutionTheory simulationTheory simulationFailTheory; val _ = new_theory "contractTransfer"; +Definition simulated_termination_def: + simulated_termination (p: 'a bir_program_t) (p': 'a bir_program_t) = + ∀s l s' o2 m2 n2. + s.bst_pc = bir_block_pc l ⇒ + MEM l (bir_labels_of_program p) ⇒ + + exec_to_prog p' s p = BER_Ended o2 m2 n2 s' ⇒ + ~(bir_state_is_terminated s') ⇒ + (∃o1 m1 n1. + exec_to_prog p s p = BER_Ended o1 m1 n1 s') +End + +Theorem simulated_simulated_termination: + ∀p p'. simulated p p' ⇒ simulated_termination p p' +Proof +FULL_SIMP_TAC (std_ss++holBACore_ss) + [simulated_def, simulated_termination_def, + bir_state_is_terminated_def] +QED + +Theorem simulated_fail_simulated_termination: + ∀p p'. simulated_fail p p' ⇒ simulated_termination p p' +Proof +FULL_SIMP_TAC (std_ss++holBACore_ss) + [simulated_fail_def, simulated_termination_def, + bir_state_is_terminated_def] +QED + Definition exec_to_prog_n_def: exec_to_prog_n p s pls n = bir_exec_to_labels_n (set (bir_labels_of_program pls)) p s n End (*TODO: Strenthen simulation definitions wrt observations and steps?*) -Definition simulated_n_def: - simulated_n p p' = +Definition simulated_termination_n_def: + simulated_termination_n p p' = ∀n s l s' os2 m2 n2. s.bst_pc = bir_block_pc l ⇒ MEM l (bir_labels_of_program p) ⇒ exec_to_prog_n p' s p n = BER_Ended os2 m2 n2 s' ⇒ - ~(∃l'. s'.bst_status = BST_JumpOutside l') ⇒ + ~(bir_state_is_terminated s') ⇒ (∃os1 m1 n1. exec_to_prog_n p s p n = BER_Ended os1 m1 n1 s') End -Theorem simulated_simulated_n: - ∀p p'. simulated p p' ⇒ simulated_n p p' +Theorem simulated_termination_simulated_termination_n: + ∀p p'. simulated_termination p p' ⇒ simulated_termination_n p p' Proof REPEAT STRIP_TAC >> -SIMP_TAC std_ss [simulated_n_def, exec_to_prog_n_def] >> +SIMP_TAC std_ss [simulated_termination_n_def, exec_to_prog_n_def] >> Q.ABBREV_TAC ‘ls = bir_labels_of_program p’ >> Induct_on ‘n’ >- ( @@ -48,23 +76,17 @@ SIMP_TAC (std_ss++holBACore_ss) [] >> rename1 ‘_ = BER_Ended os21 m21 n21 s2’ >> (*There is a contradiction or p takes the same step*) -Cases_on ‘(∃l'. s2.bst_status = BST_JumpOutside l')’ >- ( +Cases_on ‘bir_state_is_terminated s2’ >- ( FULL_SIMP_TAC (list_ss++holBACore_ss) [bir_state_is_terminated_def, bir_exec_to_labels_n_REWR_TERMINATED] >> STRIP_TAC >> FULL_SIMP_TAC (std_ss++holBACore_ss) [] ) >> subgoal ‘(∃os11 m11 n11. bir_exec_to_labels (set ls) p s = BER_Ended os11 m11 n11 s2)’ >- ( - FULL_SIMP_TAC (std_ss++holBACore_ss) [simulated_def, exec_to_prog_def] + FULL_SIMP_TAC (std_ss++holBACore_ss) [simulated_termination_def, exec_to_prog_def] ) >> ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> -(*If programs are terminated, rest of steps are same (needed to use induction hypothesis)*) -Cases_on ‘(bir_state_is_terminated s2)’ >- ( - FULL_SIMP_TAC (list_ss++holBACore_ss) [bir_state_is_terminated_def, - bir_exec_to_labels_n_REWR_TERMINATED] -) >> - (*Program p' takes the rest of the steps*) Cases_on ‘bir_exec_to_labels_n (set ls) p' s2 n’ >> SIMP_TAC (std_ss++holBACore_ss) [] >> @@ -129,8 +151,8 @@ Definition simulated_contract_def: bir_exec_to_labels ls p s = BER_Ended os1 m1 n1 s') End -Theorem simulated_simulated_contract: - ∀p p'. simulated p p' ⇒ simulated_contract p p' +Theorem simulated_termination_simulated_contract: + ∀p p'. simulated_termination p p' ⇒ simulated_contract p p' Proof REPEAT STRIP_TAC >> SIMP_TAC std_ss [simulated_contract_def, exec_to_prog_n_def] >> @@ -146,10 +168,8 @@ rename1 ‘_ = BER_Ended _ _ n2' _’ >> (*Use simulation hypothesis*) subgoal ‘∃os1 m1 n1. bir_exec_to_labels_n (set pls) p s n = BER_Ended os1 m1 n1 s'’ >- ( - subgoal ‘~(∃l'. s'.bst_status = BST_JumpOutside l')’ >- ( - FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] - ) >> - METIS_TAC [simulated_simulated_n, simulated_n_def, exec_to_prog_n_def] + METIS_TAC [simulated_termination_simulated_termination_n, + simulated_termination_n_def, exec_to_prog_n_def] ) >> (*Restrict label set*) @@ -165,15 +185,15 @@ subgoal ‘∃n1'.bir_exec_to_labels ls p s = BER_Ended os1 m1 n1' s'’ >- ( Q.PAT_X_ASSUM ‘∀n'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘n'’ thm)) >> REV_FULL_SIMP_TAC std_ss [] >> - subgoal ‘~(∃l'. s''.bst_status = BST_JumpOutside l')’ >- ( + subgoal ‘~bir_state_is_terminated s''’ >- ( FULL_SIMP_TAC std_ss [bir_exec_to_labels_n_def] >> - ‘~bir_state_is_terminated s''’ by - IMP_RES_TAC bir_exec_steps_GEN_decrease_max_steps_Ended_terminated >> - FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] + IMP_RES_TAC bir_exec_steps_GEN_decrease_max_steps_Ended_terminated ) >> + subgoal ‘∃os' c1' c2''. bir_exec_to_labels_n (set pls) p s n' = BER_Ended os' c1' c2'' s''’ >- ( - METIS_TAC [simulated_simulated_n, simulated_n_def, exec_to_prog_n_def] + METIS_TAC [simulated_termination_simulated_termination_n, + simulated_termination_n_def, exec_to_prog_n_def] ) >> PROVE_TAC [] @@ -186,7 +206,7 @@ QED Theorem contract_transfer: ∀ p p' l ls pre post. - simulated p p' ⇒ + simulated_termination p p' ⇒ bir_vars_of_program p' = bir_vars_of_program p ⇒ MEM l (bir_labels_of_program p) ⇒ @@ -198,9 +218,8 @@ Proof SIMP_TAC std_ss [bir_exec_to_labels_triple_def] >> REPEAT STRIP_TAC >> -Q.PAT_X_ASSUM ‘simulated p p'’ - (fn thm => ASSUME_TAC (MATCH_MP simulated_simulated_contract thm)) >> - +Q.PAT_X_ASSUM ‘simulated_termination p p'’ + (fn thm => ASSUME_TAC (MATCH_MP simulated_termination_simulated_contract thm)) >> Q.PAT_X_ASSUM ‘∀s'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘s’ thm)) >> REV_FULL_SIMP_TAC std_ss [] >> rename1 ‘_ = BER_Ended o2 m2 n2 s'’ >> @@ -219,10 +238,11 @@ subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = PROVE_TAC [] QED -(*Sanity check*) +(*Sanity checks*) + Theorem resolved_contract_transfer: ∀l1 v sl p p' l ls pre post. - resolved l1 v sl p p' ⇒ + resolved l1 v sl p p' ⇒ bir_vars_of_program p' = bir_vars_of_program p ⇒ MEM l (bir_labels_of_program p) ⇒ @@ -231,8 +251,27 @@ Theorem resolved_contract_transfer: bir_exec_to_labels_triple p' l ls pre post ⇒ bir_exec_to_labels_triple p l ls pre post Proof -PROVE_TAC [contract_transfer, resolved_simulated] +PROVE_TAC [resolved_simulated, + contract_transfer, + simulated_simulated_termination] +QED + +Theorem resolved_fail_contract_transfer: + ∀l1 v p p' l ls pre post. + resolved_fail l1 v p p' ⇒ + bir_vars_of_program p' = bir_vars_of_program p ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels_triple p' l ls pre post ⇒ + bir_exec_to_labels_triple p l ls pre post +Proof +PROVE_TAC [resolved_fail_simulated_fail, + simulated_fail_simulated_termination, + contract_transfer] QED val _ = export_theory(); + From 2a27dcd0fc61d19824bb4f558ae0d6a56a558ba3 Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Mon, 12 Apr 2021 17:30:21 +0200 Subject: [PATCH 0043/1015] Remove def from names of inductive definitions --- examples/ijr/resolutionScript.sml | 8 ++++---- examples/ijr/simulationFailScript.sml | 8 ++++---- examples/ijr/simulationScript.sml | 16 ++++++++-------- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index 1d13298f0..8d304c0ce 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -9,7 +9,7 @@ open HolBACoreSimps; val _ = new_theory "resolution"; -Inductive resolved_block_def: +Inductive resolved_block: ∀l1 v sl bl1 bl2 bl3 bss e c. type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ∧ @@ -43,7 +43,7 @@ Definition fresh_label_def: ~(direct_jump_target l p)) End -Inductive resolved_def: +Inductive resolved: ∀l1 v sl p p' bl1 bl2 bl3. fresh_label (BL_Label sl) p ∧ (∀l. MEM l (bir_labels_of_program p') ⇔ @@ -63,14 +63,14 @@ Inductive resolved_def: End -Inductive resolved_fail_block_def: +Inductive resolved_fail_block: ∀l v bl1 bl2 e. bl1 = bir_block_t l [] (BStmt_Jmp (BLE_Exp e)) ∧ bl2 = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ resolved_fail_block l v bl1 bl2 End -Inductive resolved_fail_def: +Inductive resolved_fail: ∀l1 v p p' bl1 bl2. (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) ∧ diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml index dc122932a..02bbbfa5d 100644 --- a/examples/ijr/simulationFailScript.sml +++ b/examples/ijr/simulationFailScript.sml @@ -72,7 +72,7 @@ rename1 ‘_ = BER_Ended o2' m2' n2' s''’ >> REVERSE (Cases_on ‘l = l1’) >- ( ‘∃bl. bir_get_current_block p s.bst_pc = SOME bl ∧ bir_get_current_block p' s.bst_pc = SOME bl’ by ( - PROVE_TAC [resolved_fail_def_cases] + PROVE_TAC [resolved_fail_cases] ) >> IMP_RES_TAC bir_exec_to_labels_block >> @@ -85,7 +85,7 @@ REVERSE (Cases_on ‘l = l1’) >- ( (*Programs execute block bl with same result*) Q.SUBGOAL_THEN ‘s2 = s1 ∧ os2 = os1 ∧ m2 = m1’ (fn thm => SIMP_TAC std_ss [thm]) >- ( MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘{}’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> - FULL_SIMP_TAC (std_ss++PRED_SET_ss) [resolved_fail_def_cases] + FULL_SIMP_TAC (std_ss++PRED_SET_ss) [resolved_fail_cases] ) >> (*Programs fail*) @@ -107,9 +107,9 @@ POP_ASSUM SUBST_ALL_TAC >> bir_get_current_block p s.bst_pc = SOME bl1 ∧ bir_get_current_block p' s.bst_pc = SOME bl2 ∧ resolved_fail_block l1 v bl1 bl2’ by ( - FULL_SIMP_TAC std_ss [resolved_fail_def_cases] + FULL_SIMP_TAC std_ss [resolved_fail_cases] ) >> -FULL_SIMP_TAC std_ss [resolved_fail_block_def_cases] >> +FULL_SIMP_TAC std_ss [resolved_fail_block_cases] >> Cases_on ‘bir_state_is_terminated s’ >- ( FULL_SIMP_TAC (std_ss++bir_TYPES_ss) diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml index 21ce32500..1162d147d 100644 --- a/examples/ijr/simulationScript.sml +++ b/examples/ijr/simulationScript.sml @@ -413,7 +413,7 @@ rename1 ‘_ = BER_Ended o2' m2' n2' s''’ >> REVERSE (Cases_on ‘l = l1’) >- ( ‘∃bl. bir_get_current_block p s.bst_pc = SOME bl ∧ bir_get_current_block p' s.bst_pc = SOME bl’ by ( - PROVE_TAC [resolved_def_cases] + PROVE_TAC [resolved_cases] ) >> IMP_RES_TAC bir_exec_to_labels_block >> @@ -427,7 +427,7 @@ REVERSE (Cases_on ‘l = l1’) >- ( Q.SUBGOAL_THEN ‘s2 = s1 ∧ os2 = os1 ∧ m2 = m1’ (fn thm => SIMP_TAC std_ss [thm]) >- ( MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘{sl}’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> FULL_SIMP_TAC (std_ss++PRED_SET_ss) - [resolved_def_cases, fresh_label_def, direct_jump_target_def] + [resolved_cases, fresh_label_def, direct_jump_target_def] ) >> (*Programs fail*) @@ -450,9 +450,9 @@ POP_ASSUM SUBST_ALL_TAC >> bir_get_current_block p' s.bst_pc = SOME bl2 ∧ bir_get_current_block p' (bir_block_pc (BL_Label sl)) = SOME bl3 ∧ resolved_block l1 v sl bl1 bl2 bl3’ by ( - FULL_SIMP_TAC std_ss [resolved_def_cases] + FULL_SIMP_TAC std_ss [resolved_cases] ) >> -FULL_SIMP_TAC std_ss [resolved_block_def_cases] >> +FULL_SIMP_TAC std_ss [resolved_block_cases] >> Q.ABBREV_TAC ‘c = BExp_BinPred BIExp_Equal e (BExp_Const v)’ >> IMP_RES_TAC bir_exec_to_labels_block >> @@ -466,8 +466,8 @@ FULL_SIMP_TAC std_ss [LET_DEF] >> subgoal ‘(s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ jump_fresh e (exec_stmtsB bss s) s2 sl s1 p’ >- ( MP_TAC (Q.SPECL quantifiers bir_exec_block_cjmp_jmp) >> - FULL_SIMP_TAC std_ss [resolved_def_cases, fresh_label_def, - direct_jump_target_def, resolved_block_def_cases] + FULL_SIMP_TAC std_ss [resolved_cases, fresh_label_def, + direct_jump_target_def, resolved_block_cases] ) >- ( (*Programs execute block labelled l1 with same result*) NTAC 3 (POP_ASSUM (fn thm => SIMP_TAC std_ss [GSYM thm])) >> @@ -496,7 +496,7 @@ Q.SUBGOAL_THEN ‘~(bir_state_COUNT_PC pc_cond s2)’ (fn thm => SIMP_TAC std_ss Q.UNABBREV_TAC ‘pc_cond’ >> FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_COUNT_PC_def, jump_fresh_def, - bir_block_pc_def, resolved_def_cases, fresh_label_def] + bir_block_pc_def, resolved_cases, fresh_label_def] ) >> (*Program p' executes block sl and tries to jump to e*) @@ -505,7 +505,7 @@ subgoal ‘∃s2' n. bir_exec_to_labels (set ls) p' s2 = BER_Ended [] 1 n s2' s2' = s2 with bst_pc := bir_block_pc (BL_Address v') else s2'.bst_status = BST_JumpOutside (BL_Address v')’ >- ( MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘sl’, ‘e’, ‘s2’, ‘v'’] bir_exec_to_labels_jmp) >> - FULL_SIMP_TAC (std_ss++holBACore_ss) [resolved_def_cases] + FULL_SIMP_TAC (std_ss++holBACore_ss) [resolved_cases] ) >> (*Evaluation of e in labels of p*) From 4206256bb4835d2c463358ac8ee902a7e895f987 Mon Sep 17 00:00:00 2001 From: Hamed Date: Tue, 13 Apr 2021 12:05:15 +0200 Subject: [PATCH 0044/1015] revert changes to sls prog generator --- src/tools/scamv/proggen/asm_genLib.sml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/tools/scamv/proggen/asm_genLib.sml b/src/tools/scamv/proggen/asm_genLib.sml index 083f9e95e..bafb668c9 100644 --- a/src/tools/scamv/proggen/asm_genLib.sml +++ b/src/tools/scamv/proggen/asm_genLib.sml @@ -399,15 +399,15 @@ fun arb_program_straightline_cond arb_prog_left arb_prog_right = val arb_prog = arb_prog_left >>= (fn blockl => arb_prog_right >>= (fn blockr => - arb_load_instr >>= (fn fld => + (* arb_load_instr >>= (fn fld => *) let val blockl_wexit = blockl@[Branch (NONE, rel_jmp_after blockr)] in return ( blockl_wexit @blockr - @[fld] + (* @[fld] *) ) end - ))); + (* ) *))); in arb_prog end; From dd34c7c1a8d96d14467c42bdaabd3a5543bf0f9c Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Tue, 13 Apr 2021 15:43:29 +0200 Subject: [PATCH 0045/1015] Simplify theorem propositions and proofs (#5) --- examples/ijr/resolutionScript.sml | 25 ++++++++++++++----- examples/ijr/simulationFailScript.sml | 18 ++++++-------- examples/ijr/simulationScript.sml | 35 +++++++++++---------------- 3 files changed, 41 insertions(+), 37 deletions(-) diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index 8d304c0ce..4f5a6a423 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -8,15 +8,24 @@ open HolBACoreSimps; val _ = new_theory "resolution"; +Definition cjmp_stmtE_def: + cjmp_stmtE e v sl = + BStmt_CJmp (BExp_BinPred BIExp_Equal e (BExp_Const v)) + (BLE_Label (BL_Address v)) + (BLE_Label (BL_Label sl)) +End + +Definition cjmp_block_def: + cjmp_block l1 bss e v sl = + bir_block_t l1 bss (cjmp_stmtE e v sl) +End Inductive resolved_block: - ∀l1 v sl bl1 bl2 bl3 bss e c. + ∀l1 v sl bl1 bl2 bl3 bss e. type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ∧ bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ∧ - c = BExp_BinPred BIExp_Equal e (BExp_Const v) ∧ - bl2 = bir_block_t l1 bss - (BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl))) ∧ + bl2 = cjmp_block l1 bss e v sl ∧ bl3 = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ resolved_block l1 v sl bl1 bl2 bl3 End @@ -47,7 +56,7 @@ Inductive resolved: ∀l1 v sl p p' bl1 bl2 bl3. fresh_label (BL_Label sl) p ∧ (∀l. MEM l (bir_labels_of_program p') ⇔ - MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ∧ + MEM l (bir_labels_of_program p) ∨ l = BL_Label sl) ∧ (MEM (BL_Address v) (bir_labels_of_program p)) ∧ bir_get_current_block p (bir_block_pc l1) = SOME bl1 ∧ @@ -62,11 +71,15 @@ Inductive resolved: resolved l1 v sl p p' End +Definition assert_block_def: + assert_block l v = + bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) +End Inductive resolved_fail_block: ∀l v bl1 bl2 e. bl1 = bir_block_t l [] (BStmt_Jmp (BLE_Exp e)) ∧ - bl2 = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ + bl2 = assert_block l v ⇒ resolved_fail_block l v bl1 bl2 End diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml index 02bbbfa5d..ee93b87bf 100644 --- a/examples/ijr/simulationFailScript.sml +++ b/examples/ijr/simulationFailScript.sml @@ -24,24 +24,23 @@ Definition simulated_fail_def: exec_to_prog p s p = BER_Ended o1 m1 n1 s') End -Theorem bir_exec_block_assert: +Theorem bir_exec_block_assert_block: ∀p l v s bl. ~(bir_state_is_terminated s) ⇒ - bl = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ + bl = assert_block l v ⇒ (∃s'. bir_exec_block p bl s = ([], 1, s') ∧ s'.bst_status = BST_AssertionViolated) Proof -REPEAT STRIP_TAC >> FULL_SIMP_TAC (list_ss++wordsLib.WORD_ss++holBACore_ss) - [bir_exec_block_def, bir_exec_stmtsB_def, + [assert_block_def, bir_exec_block_def, bir_exec_stmtsB_def, bir_exec_stmtB_def, bir_exec_stmt_assert_def, bir_dest_bool_val_def, LET_DEF, OPT_CONS_REWRS] QED -Theorem bir_exec_to_labels_assert: +Theorem bir_exec_to_labels_assert_block: ∀l v ls p s bl. ~(bir_state_is_terminated s) ⇒ - bl = bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) ⇒ + bl = assert_block l v ⇒ bir_get_current_block p (s.bst_pc) = SOME bl ⇒ (∃s'. bir_exec_to_labels ls p s = BER_Ended [] 1 0 s' ∧ s'.bst_status = BST_AssertionViolated) @@ -49,9 +48,8 @@ Proof REPEAT STRIP_TAC >> IMP_RES_TAC bir_exec_to_labels_block >> Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm]) >> -IMP_RES_TAC bir_exec_block_assert >> -Q.PAT_X_ASSUM `∀p. _` (fn thm => ASSUME_TAC (Q.SPEC `p` thm)) >> -FULL_SIMP_TAC std_ss [LET_DEF] >> +IMP_RES_TAC bir_exec_block_assert_block >> +Q.PAT_X_ASSUM `∀p. _` (fn thm => ASSUME_TAC (Q.SPECL [‘p’] thm)) >> FULL_SIMP_TAC (list_ss++holBACore_ss) [LET_DEF, bir_state_COUNT_PC_def, bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] @@ -115,7 +113,7 @@ Cases_on ‘bir_state_is_terminated s’ >- ( FULL_SIMP_TAC (std_ss++bir_TYPES_ss) [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] ) >> -IMP_RES_TAC bir_exec_to_labels_assert >> +IMP_RES_TAC bir_exec_to_labels_assert_block >> POP_ASSUM (fn thm => ASSUME_TAC (Q.SPEC ‘set ls’ thm)) >> REPEAT STRIP_TAC >> FULL_SIMP_TAC (std_ss++holBACore_ss) [] diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml index 1162d147d..081493d7a 100644 --- a/examples/ijr/simulationScript.sml +++ b/examples/ijr/simulationScript.sml @@ -196,8 +196,7 @@ Theorem bir_exec_stmtE_cjmp_jmp: type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ⇒ es1 = BStmt_Jmp (BLE_Exp e) ⇒ - c = BExp_BinPred BIExp_Equal e (BExp_Const v) ⇒ - es2 = BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl)) ⇒ + es2 = cjmp_stmtE e v sl ⇒ s.bst_status = BST_Running ⇒ bir_exec_stmtE p' es2 s = s2 ⇒ @@ -205,8 +204,9 @@ Theorem bir_exec_stmtE_cjmp_jmp: (s1 = s2 ∨ jump_fresh e s s2 sl s1 p) Proof REPEAT GEN_TAC >> NTAC 3 STRIP_TAC >> -SIMP_TAC (std_ss++holBACore_ss) [bir_exec_stmtE_def, bir_exec_stmt_cjmp_def, LET_DEF] >> -NTAC 3 (DISCH_THEN (K ALL_TAC)) >> +SIMP_TAC (std_ss++holBACore_ss) [cjmp_stmtE_def, bir_exec_stmtE_def, + bir_exec_stmt_cjmp_def, LET_DEF] >> +NTAC 2 (DISCH_THEN (K ALL_TAC)) >> rename1 ‘MEM (BL_Address v') _’ >> (*e not well typed*) @@ -250,7 +250,7 @@ Definition exec_stmtsB_def: s' End -(*TODO: Last case in bir_exec_block_cjmp_jmp and resolved_simulated chaosy *) +(*TODO: Last case in bir_exec_block_cjmp_jmp and resolved_simulated chaosy*) Theorem bir_exec_block_cjmp_jmp: ∀p' p sl bl1 l1 bss e c v bl2 s s2 os2 m2 s1 os1 m1. @@ -261,27 +261,24 @@ Theorem bir_exec_block_cjmp_jmp: type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ⇒ bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ⇒ - c = BExp_BinPred BIExp_Equal e (BExp_Const v) ⇒ - bl2 = bir_block_t l1 bss - (BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl))) ⇒ + bl2 = cjmp_block l1 bss e v sl ⇒ bir_exec_block p' bl2 s = (os2, m2, s2) ⇒ bir_exec_block p bl1 s = (os1, m1, s1) ⇒ - (s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ (jump_fresh e (exec_stmtsB bss s) s2 sl s1 p) + (s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ + (jump_fresh e (exec_stmtsB bss s) s2 sl s1 p) Proof REPEAT GEN_TAC >> NTAC 4 STRIP_TAC >> rename1 ‘bir_exec_block p' _ _= (os2', m2', s2')’ >> rename1 ‘bir_exec_block p _ _ = (os1', m1', s1')’ >> (*Execution of basic statements has same result*) -SIMP_TAC (std_ss++bir_TYPES_ss) [bir_exec_block_def] >> -NTAC 3 (DISCH_THEN (K ALL_TAC)) >> +SIMP_TAC (std_ss++bir_TYPES_ss) [bir_exec_block_def, cjmp_block_def] >> +NTAC 2 (DISCH_THEN (K ALL_TAC)) >> ‘∃os m s'. bir_exec_stmtsB bss ([], 0, s) = (os, m, s')’ by PROVE_TAC [pairTheory.PAIR] >> -Q.ABBREV_TAC ‘c = BExp_BinPred BIExp_Equal e (BExp_Const v)’ >> -Q.ABBREV_TAC ‘s2 = bir_exec_stmtE p' - (BStmt_CJmp c (BLE_Label (BL_Address v)) (BLE_Label (BL_Label sl))) s'’ >> +Q.ABBREV_TAC ‘s2 = bir_exec_stmtE p' (cjmp_stmtE e v sl) s'’ >> Q.ABBREV_TAC ‘s1 = bir_exec_stmtE p (BStmt_Jmp (BLE_Exp e)) s'’ >> FULL_SIMP_TAC std_ss [LET_DEF] >> @@ -393,10 +390,6 @@ FULL_SIMP_TAC (std_ss++holBACore_ss) QED -val quantifiers = [‘p'’, ‘p’, ‘sl’, ‘bl1’, ‘l1’, ‘bss’, ‘e’, ‘c’, ‘v’, - ‘bl2’, ‘s’, ‘s2’, ‘os2’, ‘m2’, ‘s1’, ‘os1’, ‘m1’] - - (*TODO: simplify repetitiveness in cases?*) Theorem resolved_simulated: ∀l1 v sl p p'. @@ -453,7 +446,6 @@ POP_ASSUM SUBST_ALL_TAC >> FULL_SIMP_TAC std_ss [resolved_cases] ) >> FULL_SIMP_TAC std_ss [resolved_block_cases] >> -Q.ABBREV_TAC ‘c = BExp_BinPred BIExp_Equal e (BExp_Const v)’ >> IMP_RES_TAC bir_exec_to_labels_block >> NTAC 2 (Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm])) >> @@ -465,7 +457,8 @@ FULL_SIMP_TAC std_ss [LET_DEF] >> (*e = v*) subgoal ‘(s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ jump_fresh e (exec_stmtsB bss s) s2 sl s1 p’ >- ( - MP_TAC (Q.SPECL quantifiers bir_exec_block_cjmp_jmp) >> + IRULE_TAC bir_exec_block_cjmp_jmp >> + Q.LIST_EXISTS_TAC [‘bl1’, ‘bl2’, ‘l1’, ‘p'’, ‘v’] >> FULL_SIMP_TAC std_ss [resolved_cases, fresh_label_def, direct_jump_target_def, resolved_block_cases] ) >- ( @@ -504,7 +497,7 @@ subgoal ‘∃s2' n. bir_exec_to_labels (set ls) p' s2 = BER_Ended [] 1 n s2' if MEM (BL_Address v') (bir_labels_of_program p) then s2' = s2 with bst_pc := bir_block_pc (BL_Address v') else s2'.bst_status = BST_JumpOutside (BL_Address v')’ >- ( - MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘sl’, ‘e’, ‘s2’, ‘v'’] bir_exec_to_labels_jmp) >> + IRULE_TAC bir_exec_to_labels_jmp >> FULL_SIMP_TAC (std_ss++holBACore_ss) [resolved_cases] ) >> From f461c9744b3c9191d45b8be5f30d5a920b2af18e Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Tue, 13 Apr 2021 18:21:57 +0200 Subject: [PATCH 0046/1015] Generalise definition of ijr fail case and corresponding simulation proof (#6) * Generalise definition of ijr fail case and the corresponding simulation proof --- examples/ijr/resolutionScript.sml | 8 +-- examples/ijr/simulationFailScript.sml | 97 ++++++++++++++++++--------- 2 files changed, 71 insertions(+), 34 deletions(-) diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index 4f5a6a423..8187056e6 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -72,14 +72,14 @@ Inductive resolved: End Definition assert_block_def: - assert_block l v = - bir_block_t l [BStmt_Assert (BExp_Const (Imm1 0w))] (BStmt_Halt v) + assert_block l bss v = + bir_block_t l (bss ++ [BStmt_Assert (BExp_Const (Imm1 0w))]) (BStmt_Halt v) End Inductive resolved_fail_block: ∀l v bl1 bl2 e. - bl1 = bir_block_t l [] (BStmt_Jmp (BLE_Exp e)) ∧ - bl2 = assert_block l v ⇒ + bl1 = bir_block_t l bss (BStmt_Jmp (BLE_Exp e)) ∧ + bl2 = assert_block l bss v ⇒ resolved_fail_block l v bl1 bl2 End diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml index ee93b87bf..f36233180 100644 --- a/examples/ijr/simulationFailScript.sml +++ b/examples/ijr/simulationFailScript.sml @@ -24,35 +24,60 @@ Definition simulated_fail_def: exec_to_prog p s p = BER_Ended o1 m1 n1 s') End -Theorem bir_exec_block_assert_block: - ∀p l v s bl. - ~(bir_state_is_terminated s) ⇒ - bl = assert_block l v ⇒ - (∃s'. bir_exec_block p bl s = ([], 1, s') ∧ - s'.bst_status = BST_AssertionViolated) +Theorem bir_exec_stmsB_assert_cjmp: + ∀bss os c s os2 m2 s2 os1 m1 s1. + bir_exec_stmtsB (bss ⧺ [BStmt_Assert (BExp_Const (Imm1 0w))]) (os, c, s) = (os2, m2, s2) ⇒ + bir_exec_stmtsB bss (os, c, s) = (os1, m1, s1) ⇒ + (s1 = s2 ∧ os1 = os2 ∧ m1 = m2 ∧ bir_state_is_terminated s2) ∨ + (s2.bst_status = BST_AssertionViolated) Proof +REPEAT GEN_TAC >> +SIMP_TAC std_ss [bir_exec_stmtsB_APPEND] >> +NTAC 2 STRIP_TAC >> FULL_SIMP_TAC (list_ss++wordsLib.WORD_ss++holBACore_ss) - [assert_block_def, bir_exec_block_def, bir_exec_stmtsB_def, + [LET_DEF, bir_exec_stmtsB_def, bir_exec_stmtB_def, bir_exec_stmt_assert_def, - bir_dest_bool_val_def, LET_DEF, OPT_CONS_REWRS] + bir_dest_bool_val_def, OPT_CONS_REWRS] >> +Cases_on ‘bir_state_is_terminated s1’ >> +FULL_SIMP_TAC std_ss [] >> +Q.PAT_X_ASSUM ‘_ = s2’ (fn thm => ASM_SIMP_TAC (std_ss++holBACore_ss) [GSYM thm]) QED -Theorem bir_exec_to_labels_assert_block: - ∀l v ls p s bl. - ~(bir_state_is_terminated s) ⇒ - bl = assert_block l v ⇒ - bir_get_current_block p (s.bst_pc) = SOME bl ⇒ - (∃s'. bir_exec_to_labels ls p s = BER_Ended [] 1 0 s' ∧ - s'.bst_status = BST_AssertionViolated) +Theorem bir_exec_block_assert_jmp: + ∀p' p l1 bss e s v s2 s1 os2 m2 os1 m1 bl1 bl2. + bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ⇒ + bl2 = assert_block l1 bss v ⇒ + + bir_exec_block p' bl2 s = (os2, m2, s2) ⇒ + bir_exec_block p bl1 s = (os1, m1, s1) ⇒ + ((s1 = s2 ∧ os1 = os2 ∧ m1 = m2 ∧ bir_state_is_terminated s2) ∨ + (s2.bst_status = BST_AssertionViolated)) Proof -REPEAT STRIP_TAC >> -IMP_RES_TAC bir_exec_to_labels_block >> -Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm]) >> -IMP_RES_TAC bir_exec_block_assert_block >> -Q.PAT_X_ASSUM `∀p. _` (fn thm => ASSUME_TAC (Q.SPECL [‘p’] thm)) >> -FULL_SIMP_TAC (list_ss++holBACore_ss) [LET_DEF, bir_state_COUNT_PC_def, - bir_exec_to_labels_def, - bir_exec_to_labels_n_REWR_TERMINATED] +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +rename1 ‘bir_exec_block p' _ _ = (os2', m2', s2'')’ >> +rename1 ‘bir_exec_block p _ _ = (os1', m1', s1'')’ >> + +ASM_SIMP_TAC (std_ss++holBACore_ss) [assert_block_def, bir_exec_block_def] >> +‘∃os2 m2 s2. bir_exec_stmtsB (bss ⧺ [BStmt_Assert (BExp_Const (Imm1 0w))]) + ([],0,s) = (os2, m2, s2)’ + by PROVE_TAC [pairTheory.PAIR] >> +‘∃os1 m1 s1. bir_exec_stmtsB bss ([],0,s) = (os1, m1, s1)’ + by PROVE_TAC [pairTheory.PAIR] >> +Q.ABBREV_TAC ‘s2' = bir_exec_stmtE p' (BStmt_Halt v) s2’ >> +Q.ABBREV_TAC ‘s1' = bir_exec_stmtE p (BStmt_Jmp (BLE_Exp e)) s1’ >> +FULL_SIMP_TAC std_ss [LET_DEF] >> + +subgoal ‘(s1 = s2 ∧ os1 = os2 ∧ m1 = m2 ∧ bir_state_is_terminated s2) ∨ + (s2.bst_status = BST_AssertionViolated)’ >- ( + PROVE_TAC [bir_exec_stmsB_assert_cjmp] +) >> +FULL_SIMP_TAC (std_ss++holBACore_ss) [] >> +REPEAT STRIP_TAC >- ( + NTAC 6 (POP_ASSUM (fn thm => SIMP_TAC std_ss [GSYM thm])) >> + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_is_terminated_def] +) >> +NTAC 4 (POP_ASSUM (fn thm => SIMP_TAC std_ss [GSYM thm])) >> +FULL_SIMP_TAC (std_ss++holBACore_ss) [] QED Theorem resolved_fail_simulated_fail: @@ -109,14 +134,26 @@ POP_ASSUM SUBST_ALL_TAC >> ) >> FULL_SIMP_TAC std_ss [resolved_fail_block_cases] >> -Cases_on ‘bir_state_is_terminated s’ >- ( - FULL_SIMP_TAC (std_ss++bir_TYPES_ss) - [bir_exec_to_labels_def, bir_exec_to_labels_n_REWR_TERMINATED] +IMP_RES_TAC bir_exec_to_labels_block >> +NTAC 2 (Q.PAT_X_ASSUM `∀ls. _` (fn thm => SIMP_TAC std_ss [Q.SPEC `ls` thm])) >> +Q.ABBREV_TAC ‘pc_cond = (F, (λpc. pc.bpc_index = 0 ∧ MEM pc.bpc_label ls))’ >> +‘∃os2 m2 s2. bir_exec_block p' bl2 s = (os2, m2, s2)’ by PROVE_TAC [pairTheory.PAIR] >> +‘∃os1 m1 s1. bir_exec_block p bl1 s = (os1, m1, s1)’ by PROVE_TAC [pairTheory.PAIR] >> +FULL_SIMP_TAC std_ss [LET_DEF] >> + +subgoal ‘(s1 = s2 ∧ os1 = os2 ∧ m1 = m2 ∧ bir_state_is_terminated s2) ∨ + (s2.bst_status = BST_AssertionViolated)’ >- ( + PROVE_TAC [bir_exec_block_assert_jmp] +) >- ( + FULL_SIMP_TAC (list_ss++holBACore_ss) [bir_exec_to_labels_def, + bir_exec_to_labels_n_REWR_TERMINATED] ) >> -IMP_RES_TAC bir_exec_to_labels_assert_block >> -POP_ASSUM (fn thm => ASSUME_TAC (Q.SPEC ‘set ls’ thm)) >> -REPEAT STRIP_TAC >> -FULL_SIMP_TAC (std_ss++holBACore_ss) [] +Q.UNABBREV_TAC ‘pc_cond’ >> +FULL_SIMP_TAC (list_ss++holBACore_ss) [Once bir_state_COUNT_PC_def, + bir_exec_to_labels_def, + bir_exec_to_labels_n_REWR_TERMINATED] >> + +PROVE_TAC [] QED From 50ad753480586c8b7b0e18aaeb1fd23e6a0cc6b2 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Wed, 14 Apr 2021 10:29:53 +0200 Subject: [PATCH 0047/1015] Add transitivity theorem for general simulation (#7) * Add transitivity theorem for simulated_termination simulation --- examples/ijr/contractTransferScript.sml | 67 ++++++++++++++++++++++++- 1 file changed, 66 insertions(+), 1 deletion(-) diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index 53b847528..51a8bc300 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -1,6 +1,6 @@ open HolKernel Parse boolLib bossLib; -open listTheory; +open listTheory pred_setTheory pred_setSimps; open bir_programTheory bir_htTheory bir_program_multistep_propsTheory; open HolBACoreSimps; @@ -138,6 +138,71 @@ Proof cheat QED +Theorem simulated_termination_transitive: + ∀p1 p2 p3. + set (bir_labels_of_program p1) SUBSET set (bir_labels_of_program p2) ⇒ + simulated_termination p1 p2 ∧ + simulated_termination p2 p3 ⇒ + simulated_termination p1 p3 +Proof +REPEAT STRIP_TAC >> +SIMP_TAC std_ss [simulated_termination_def, exec_to_prog_def] >> +Q.ABBREV_TAC ‘pls1 = set (bir_labels_of_program p1)’ >> +Q.ABBREV_TAC ‘pls2 = set (bir_labels_of_program p2)’ >> + +(*Expand label set*) +REPEAT STRIP_TAC >> +MP_TAC (Q.SPECL [‘pls1’, ‘pls2’, ‘p3’, ‘s’, ‘s'’, ‘o2’, ‘m2’, ‘n2’] + bir_exec_to_labels_expand_labels) >> +ASM_SIMP_TAC std_ss [] >> STRIP_TAC >> +rename1 ‘_ = BER_Ended _ _ n2' _’ >> + +(*Use simulation hypothesis*) +subgoal ‘∃os1 m1 n1. bir_exec_to_labels_n pls2 p2 s n = + BER_Ended os1 m1 n1 s'’ >- ( + Q.SUBGOAL_THEN ‘simulated_termination_n p2 p3’ MP_TAC >- ( + PROVE_TAC [simulated_termination_simulated_termination_n] + ) >> + ASM_SIMP_TAC std_ss [simulated_termination_n_def, exec_to_prog_n_def] >> + PROVE_TAC [SUBSET_DEF] +) >> + +(*Restrict label set*) +subgoal ‘∃n1'.bir_exec_to_labels pls1 p2 s = BER_Ended os1 m1 n1' s'’ >- ( + IRULE_TAC bir_exec_to_labels_restrict_labels >> + CONJ_TAC >- ( + ‘(1:num) > 0’ by SIMP_TAC arith_ss [] >> + METIS_TAC [bir_exec_to_labels_def, bir_exec_to_labels_n_ended_running] + ) >> + + Q.LIST_EXISTS_TAC [‘n1’, ‘pls2’, ‘n’] >> CONJ_TAC >- ( + REPEAT STRIP_TAC >> + Q.PAT_X_ASSUM ‘∀n'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘n'’ thm)) >> + REV_FULL_SIMP_TAC std_ss [] >> + + subgoal ‘~bir_state_is_terminated s''’ >- ( + FULL_SIMP_TAC std_ss [bir_exec_to_labels_n_def] >> + IMP_RES_TAC bir_exec_steps_GEN_decrease_max_steps_Ended_terminated + ) >> + + subgoal ‘∃os' c1' c2''. bir_exec_to_labels_n pls2 p2 s n' = + BER_Ended os' c1' c2'' s''’ >- ( + Q.SUBGOAL_THEN ‘simulated_termination_n p2 p3’ MP_TAC >- ( + PROVE_TAC [simulated_termination_simulated_termination_n] + ) >> + ASM_SIMP_TAC std_ss [simulated_termination_n_def, exec_to_prog_n_def] >> + PROVE_TAC [SUBSET_DEF] + ) >> + + PROVE_TAC [] + ) >> + + ASM_SIMP_TAC std_ss [] +) >> + +METIS_TAC [simulated_termination_def, exec_to_prog_def] +QED + Definition simulated_contract_def: simulated_contract p p' = ∀s l ls s' os2 m2 n2. From 8e658de41c6ac42254407831f2d6e8b8ca2e1eb8 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Tue, 20 Apr 2021 10:38:04 +0200 Subject: [PATCH 0048/1015] Add implementations of ijr steps and soundness and variable refinement theorems (#8) * Add implementation of resolved (resolve_def) * Add soundness theorem (resolve_sound), simulation corollary (resolve_simulated_termination), and variable refinement theorem (resolve_vars) * Add implementation of resolved_fail (resolve_fail_def) * Add soundness theorem (resolve_fail_sound), simulation corollary (resolve_fail_simulated_termination), and variable refinement theorem (resolve_fail_vars) --- examples/ijr/contractTransferScript.sml | 48 +-- examples/ijr/examplesScript.sml | 37 ++ examples/ijr/resolutionScript.sml | 68 +++- examples/ijr/resolveScript.sml | 506 ++++++++++++++++++++++++ examples/ijr/simulationFailScript.sml | 2 +- examples/ijr/simulationScript.sml | 9 +- 6 files changed, 621 insertions(+), 49 deletions(-) create mode 100644 examples/ijr/examplesScript.sml create mode 100644 examples/ijr/resolveScript.sml diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index 51a8bc300..f73f672f5 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -272,7 +272,7 @@ QED Theorem contract_transfer: ∀ p p' l ls pre post. simulated_termination p p' ⇒ - bir_vars_of_program p' = bir_vars_of_program p ⇒ + (bir_vars_of_program p') SUBSET (bir_vars_of_program p) ⇒ MEM l (bir_labels_of_program p) ⇒ ls SUBSET (set (bir_labels_of_program p)) ⇒ @@ -282,11 +282,15 @@ Theorem contract_transfer: Proof SIMP_TAC std_ss [bir_exec_to_labels_triple_def] >> REPEAT STRIP_TAC >> - Q.PAT_X_ASSUM ‘simulated_termination p p'’ - (fn thm => ASSUME_TAC (MATCH_MP simulated_termination_simulated_contract thm)) >> -Q.PAT_X_ASSUM ‘∀s'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘s’ thm)) >> -REV_FULL_SIMP_TAC std_ss [] >> + (ASSUME_TAC o MATCH_MP simulated_termination_simulated_contract) >> + +Q.PAT_X_ASSUM ‘∀s'. _’ (MP_TAC o Q.SPEC ‘s’) >> +subgoal ‘bir_env_vars_are_initialised s.bst_environ (bir_vars_of_program p')’ >- ( + IRULE_TAC bir_env_oldTheory.bir_env_vars_are_initialised_SUBSET >> + PROVE_TAC [] +) >> +ASM_SIMP_TAC std_ss [] >> STRIP_TAC >> rename1 ‘_ = BER_Ended o2 m2 n2 s'’ >> subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = @@ -303,40 +307,6 @@ subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = PROVE_TAC [] QED -(*Sanity checks*) - -Theorem resolved_contract_transfer: - ∀l1 v sl p p' l ls pre post. - resolved l1 v sl p p' ⇒ - bir_vars_of_program p' = bir_vars_of_program p ⇒ - - MEM l (bir_labels_of_program p) ⇒ - ls SUBSET (set (bir_labels_of_program p)) ⇒ - - bir_exec_to_labels_triple p' l ls pre post ⇒ - bir_exec_to_labels_triple p l ls pre post -Proof -PROVE_TAC [resolved_simulated, - contract_transfer, - simulated_simulated_termination] -QED - -Theorem resolved_fail_contract_transfer: - ∀l1 v p p' l ls pre post. - resolved_fail l1 v p p' ⇒ - bir_vars_of_program p' = bir_vars_of_program p ⇒ - - MEM l (bir_labels_of_program p) ⇒ - ls SUBSET (set (bir_labels_of_program p)) ⇒ - - bir_exec_to_labels_triple p' l ls pre post ⇒ - bir_exec_to_labels_triple p l ls pre post -Proof -PROVE_TAC [resolved_fail_simulated_fail, - simulated_fail_simulated_termination, - contract_transfer] -QED - val _ = export_theory(); diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml new file mode 100644 index 000000000..7c2a58403 --- /dev/null +++ b/examples/ijr/examplesScript.sml @@ -0,0 +1,37 @@ +open HolKernel Parse boolLib bossLib; + +open bslSyntax bir_execLib; + +open resolveTheory; + +val _ = new_theory "examples"; + + +val observe_type = Type `: 'a` +val bdefprog_list = bdefprog_list observe_type + +val block1 = (blabel_addr32 0, + [bassign (bvarimm32 "y", bconst32 4)], + (bjmp o belabel_expr o bden o bvarimm32) "y") + +val block2: term * term list * term = (blabel_addr32 4, [], (bhalt o bconst32) 0) + +val prog_def = bdefprog_list "prog" [block1, block2] +val prog = (snd o dest_eq o concl) prog_def + +val n_max = 10; +val _ = bir_exec_prog_print "prog" prog n_max NONE NONE NONE; + +val prog'_def = EVAL “resolve_fail ^prog (BL_Address (Imm32 0w))” +val prog' = (dest_some o snd o dest_eq o concl) prog'_def + +val _ = bir_exec_prog_print "prog'" prog' n_max NONE NONE NONE; + +val prog'_def = EVAL “resolve ^prog (BL_Address (Imm32 0w)) (Imm32 10w) "fresh"” +val prog' = (dest_some o snd o dest_eq o concl) prog'_def + +(*val _ = bir_exec_prog_print "prog'" prog' n_max NONE NONE NONE;*) + + +val _ = export_theory(); + diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index 8187056e6..ed881358f 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -1,8 +1,8 @@ open HolKernel Parse boolLib bossLib; -open listTheory; +open listTheory pred_setTheory pred_setSimps; -open bir_programTheory bir_expTheory bir_exp_immTheory; +open bir_programTheory bir_expTheory bir_exp_immTheory bir_typing_progTheory; open bir_program_blocksTheory bir_program_multistep_propsTheory; open HolBACoreSimps; @@ -17,7 +17,16 @@ End Definition cjmp_block_def: cjmp_block l1 bss e v sl = - bir_block_t l1 bss (cjmp_stmtE e v sl) + <| bb_label := l1; + bb_statements := bss; + bb_last_statement := cjmp_stmtE e v sl |> +End + +Definition jmp_block_def: + jmp_block sl e = + <| bb_label := BL_Label sl; + bb_statements := []; + bb_last_statement := BStmt_Jmp (BLE_Exp e) |> End Inductive resolved_block: @@ -26,10 +35,33 @@ Inductive resolved_block: bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ∧ bl2 = cjmp_block l1 bss e v sl ∧ - bl3 = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ + bl3 = jmp_block sl e ⇒ resolved_block l1 v sl bl1 bl2 bl3 End +Theorem resolved_block_labels: + ∀l v sl bl1 bl2 bl3. + resolved_block l v sl bl1 bl2 bl3 ⇒ + bl1.bb_label = l ∧ bl2.bb_label = l ∧ bl3.bb_label = BL_Label sl +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (std_ss++holBACore_ss) + [resolved_block_cases, cjmp_block_def, jmp_block_def] +QED + +Theorem resolved_block_vars: + ∀l1 v sl bl1 bl2 bl3. + resolved_block l1 v sl bl1 bl2 bl3 ⇒ + (bir_vars_of_block bl2 UNION bir_vars_of_block bl3) + SUBSET bir_vars_of_block bl1 +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (list_ss++PRED_SET_ss++holBACore_ss) + [resolved_block_cases, cjmp_block_def, jmp_block_def, + cjmp_stmtE_def, bir_vars_of_block_def, + bir_vars_of_stmtE_def, bir_vars_of_label_exp_def] +QED + Definition direct_jump_target_block_def: direct_jump_target_block l bl = ∀es. @@ -39,6 +71,7 @@ Definition direct_jump_target_block_def: ∃c l1. es = BStmt_CJmp c l1 (BLE_Label l)) End +(*TODO: maybe these should be Inductive for consistency?*) Definition direct_jump_target_def: direct_jump_target l p = ∃l' bl. @@ -71,9 +104,12 @@ Inductive resolved: resolved l1 v sl p p' End +(*Any value besides 1w is fine*) Definition assert_block_def: assert_block l bss v = - bir_block_t l (bss ++ [BStmt_Assert (BExp_Const (Imm1 0w))]) (BStmt_Halt v) + <| bb_label := l; + bb_statements := bss ++ [BStmt_Assert (BExp_Const (Imm1 0w))]; + bb_last_statement := BStmt_Halt v |> End Inductive resolved_fail_block: @@ -83,6 +119,28 @@ Inductive resolved_fail_block: resolved_fail_block l v bl1 bl2 End +Theorem resolved_fail_block_labels: + ∀l v bl1 bl2. + resolved_fail_block l v bl1 bl2 ⇒ + bl1.bb_label = l ∧ bl2.bb_label = l +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (std_ss++holBACore_ss) + [resolved_fail_block_cases, assert_block_def] +QED + +Theorem resolved_fail_block_vars: + ∀l v bl1 bl2. + resolved_fail_block l (BExp_Const v) bl1 bl2 ⇒ + bir_vars_of_block bl2 SUBSET bir_vars_of_block bl1 +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC (list_ss++PRED_SET_ss++holBACore_ss) + [resolved_fail_block_cases, assert_block_def, + bir_vars_of_block_def, bir_vars_of_stmtE_def, + bir_vars_of_stmtB_def] +QED + Inductive resolved_fail: ∀l1 v p p' bl1 bl2. (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) ∧ diff --git a/examples/ijr/resolveScript.sml b/examples/ijr/resolveScript.sml new file mode 100644 index 000000000..5f70fa09e --- /dev/null +++ b/examples/ijr/resolveScript.sml @@ -0,0 +1,506 @@ +open HolKernel Parse boolLib bossLib; + +open listTheory optionTheory pred_setTheory pred_setSimps; + +open bir_programTheory bir_expTheory bir_exp_immTheory bir_typing_progTheory; +open bir_program_blocksTheory bir_program_multistep_propsTheory; +open HolBACoreSimps; + +open resolutionTheory simulationTheory simulationFailTheory contractTransferTheory; + +val _ = new_theory "resolve"; + + +Theorem INDEX_FIND_append_stop: + ∀P xs n ys. + EXISTS P xs ⇒ + INDEX_FIND n P (xs ++ ys) = + INDEX_FIND n P xs +Proof +Induct_on ‘xs’ >> +REPEAT GEN_TAC >- ( + SIMP_TAC list_ss [] +) >> +SIMP_TAC list_ss [] >> +STRIP_TAC >> +ASM_SIMP_TAC std_ss [INDEX_FIND_def] +QED + +Theorem INDEX_FIND_append_skip: + ∀P xs n ys n' x. + EVERY ($~ o P) xs ⇒ + INDEX_FIND n P (xs ++ ys) = SOME (n', x) ⇒ + ∃n''. INDEX_FIND n P ys = SOME (n'', x) +Proof +Induct_on ‘xs’ >> +REPEAT GEN_TAC >- ( + SIMP_TAC list_ss [] +) >> +SIMP_TAC list_ss [] >> +ASM_SIMP_TAC arith_ss [INDEX_FIND_def] >> +REPEAT STRIP_TAC >> +MP_TAC (Q.SPECL [‘SUC n’, ‘n'’, ‘P’, ‘(xs ++ ys)’, ‘x’] bir_auxiliaryTheory.INDEX_FIND_PRE) >> +ASM_SIMP_TAC std_ss [] +QED + +Theorem INDEX_FIND_cons_stop: + ∀P x n xs. + P x ⇒ + INDEX_FIND n P (x::xs) = SOME (n, x) +Proof +SIMP_TAC std_ss [INDEX_FIND_def] +QED + +Theorem bir_get_program_block_info_by_label_append_stop: + ∀bls1 bls2 l. + EXISTS (\bl. bl.bb_label = l) bls1 ⇒ + bir_get_program_block_info_by_label (BirProgram (bls1 ++ bls2)) l = + bir_get_program_block_info_by_label (BirProgram bls1) l +Proof +SIMP_TAC std_ss [bir_get_program_block_info_by_label_def, + INDEX_FIND_append_stop] +QED + +Theorem bir_get_program_block_info_by_label_append_skip: + ∀l bls1 bls2 i bl. + EVERY (\bl. bl.bb_label ≠ l) bls1 ⇒ + bir_get_program_block_info_by_label (BirProgram (bls1 ++ bls2)) l = SOME (i, bl) ⇒ + ∃j. bir_get_program_block_info_by_label (BirProgram bls2) l = SOME (j, bl) +Proof +REPEAT STRIP_TAC >> +FULL_SIMP_TAC std_ss [bir_get_program_block_info_by_label_def] >> +IRULE_TAC INDEX_FIND_append_skip >> +FULL_SIMP_TAC std_ss [combinTheory.o_ABS_R] >> +PROVE_TAC [] +QED + +Theorem bir_get_program_block_info_by_label_cons_stop: + ∀bl bls l. + bl.bb_label = l ⇒ + ∃n. bir_get_program_block_info_by_label (BirProgram (bl::bls)) l = + SOME (n, bl) +Proof +SIMP_TAC std_ss [bir_get_program_block_info_by_label_def, + INDEX_FIND_cons_stop] +QED + +Theorem bir_get_current_block_append_stop: + ∀bls1 bls2 l. + EXISTS (\bl. bl.bb_label = l) bls1 ⇒ + bir_get_current_block (BirProgram (bls1 ++ bls2)) (bir_block_pc l) = + bir_get_current_block (BirProgram bls1) (bir_block_pc l) +Proof +SIMP_TAC (std_ss++holBACore_ss) + [bir_get_current_block_def, bir_block_pc_def, + bir_get_program_block_info_by_label_append_stop] +QED + +Theorem bir_get_current_block_append_skip: + ∀bls1 bls2 l. + EVERY (\bl. bl.bb_label ≠ l) bls1 ⇒ + bir_get_current_block (BirProgram (bls1 ++ bls2)) (bir_block_pc l) = + bir_get_current_block (BirProgram bls2) (bir_block_pc l) +Proof +REPEAT GEN_TAC >> STRIP_TAC >> +SIMP_TAC (std_ss++holBACore_ss) + [bir_get_current_block_def, bir_block_pc_def] >> + +Cases_on ‘bir_get_program_block_info_by_label (BirProgram bls2) l’ >> +ASM_SIMP_TAC std_ss [] >- ( + subgoal ‘∀bl. MEM bl (bls1 ++ bls2) ⇒ bl.bb_label ≠ l’ >- ( + FULL_SIMP_TAC list_ss [bir_get_program_block_info_by_label_THM, + EVERY_MEM] >> + PROVE_TAC [] + ) >> + FULL_SIMP_TAC std_ss [GSYM bir_get_program_block_info_by_label_THM] +) >> + +Cases_on ‘x’ >> rename1 ‘(j, bl')’ >> +subgoal ‘MEM l (bir_labels_of_program (BirProgram (bls1 ++ bls2)))’ >- ( + SIMP_TAC list_ss [bir_labels_of_program_def] >> + PROVE_TAC [bir_labels_of_program_def, + bir_get_program_block_info_by_label_MEM, pairTheory.PAIR] +) >> +FULL_SIMP_TAC std_ss [bir_get_program_block_info_by_label_MEM] >> +IMP_RES_TAC bir_get_program_block_info_by_label_append_skip >> +FULL_SIMP_TAC std_ss [] +QED + +Theorem bir_get_current_block_cons_stop: + ∀bl bls l. + bl.bb_label = l ⇒ + bir_get_current_block (BirProgram (bl::bls)) (bir_block_pc l) = + SOME bl +Proof +REPEAT STRIP_TAC >> +SIMP_TAC (std_ss++holBACore_ss) + [bir_get_current_block_def, bir_block_pc_def] >> +IMP_RES_TAC bir_get_program_block_info_by_label_cons_stop >> +POP_ASSUM (STRIP_ASSUME_TAC o Q.SPECL [‘bls’]) >> +ASM_SIMP_TAC std_ss [] +QED + +Theorem bir_get_current_block_cons_skip: + ∀bl bls l. + bl.bb_label ≠ l ⇒ + bir_get_current_block (BirProgram (bl::bls)) (bir_block_pc l) = + bir_get_current_block (BirProgram bls) (bir_block_pc l) +Proof +REPEAT GEN_TAC >> +MP_TAC (Q.SPECL [‘[bl]’, ‘bls’, ‘l’] bir_get_current_block_append_skip) >> +SIMP_TAC list_ss [] +QED + + +Definition replace_def: + (replace f P [] = NONE) ∧ + (replace f P (h::t) = + if P h then OPTION_MAP (\hs. hs ++ t) (f h) + else OPTION_MAP (\t'. h::t') (replace f P t)) +End + +Theorem replace_SOME: + ∀f P xs xs'. + replace f P xs = SOME xs' ⇒ + (∃xs1 y xs2 ys. + P y ∧ EVERY (\x. ~P x) xs1 ∧ + f y = SOME ys ∧ + xs = xs1 ++ y::xs2 ∧ + xs' = xs1 ++ ys ++ xs2) +Proof +Induct_on ‘xs’ >> +REPEAT GEN_TAC >> +SIMP_TAC std_ss [replace_def] >> +Cases_on ‘P h’ >> +ASM_SIMP_TAC std_ss [] >> +STRIP_TAC >- ( + Q.EXISTS_TAC ‘[]’ >> + ASM_SIMP_TAC list_ss [] +) >> + +Q.PAT_X_ASSUM ‘∀f P xs'. _’ IMP_RES_TAC >> +Q.EXISTS_TAC ‘h::xs1’ >> +ASM_SIMP_TAC list_ss [] +QED + +Definition replace_block_def: + replace_block (BirProgram p) l f = + OPTION_MAP BirProgram (replace f (\b. b.bb_label = l) p) +End + +Theorem replace_block_SOME: + ∀p l f p'. + replace_block (BirProgram p) l f = SOME (BirProgram p') ⇒ + (∃bls1 bl bls2 bls. + bl.bb_label = l ∧ EVERY (\bl. bl.bb_label ≠ l) bls1 ∧ + f bl = SOME bls ∧ + p = bls1 ++ bl::bls2 ∧ + p' = bls1 ++ bls ++ bls2) +Proof +REPEAT GEN_TAC >> +SIMP_TAC (std_ss++bir_TYPES_ss) [replace_block_def] >> +STRIP_TAC >> +IMP_RES_TAC replace_SOME >> +PROVE_TAC [] +QED + +Definition refines_vars_def: + refines_vars f = + ∀bl bls. + f bl = SOME bls ⇒ + BIGUNION (IMAGE bir_vars_of_block (set bls)) SUBSET bir_vars_of_block bl +End + +(*Actually set equality should hold in all reasonable cases since + variables should be used elsewhere, but is harder to prove and is not necessary*) +Theorem replace_block_SOME_vars: + ∀p l f p'. + refines_vars f ⇒ + replace_block p l f = SOME p' ⇒ + bir_vars_of_program p' SUBSET bir_vars_of_program p +Proof +REPEAT GEN_TAC >> STRIP_TAC >> +Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> +Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> +DISCH_THEN (STRIP_ASSUME_TAC o MATCH_MP replace_block_SOME) >> +ASM_SIMP_TAC (list_ss++PRED_SET_ss) [bir_vars_of_program_def] >> +FULL_SIMP_TAC std_ss [refines_vars_def, SUBSET_DEF, IN_UNION] +QED + + +Definition resolve_fail_block_def: + (resolve_fail_block bl = + case bl.bb_last_statement of + BStmt_Jmp (BLE_Exp e) => + SOME [assert_block bl.bb_label bl.bb_statements (BExp_Const (Imm1 0w))] + | _ => NONE) +End + +Theorem resolve_fail_block_sound: + ∀bl1 r. + resolve_fail_block bl1 = SOME r ⇒ + (∃bl2. r = [bl2] ∧ + resolved_fail_block (bl1.bb_label) (BExp_Const (Imm1 0w)) bl1 bl2) +Proof +REPEAT GEN_TAC >> +Cases_on ‘bl1’ >> +rename1 ‘bir_block_t l1 bss es’ >> +Cases_on ‘es’ >> +SIMP_TAC (std_ss++holBACore_ss) [resolve_fail_block_def] >> +rename1 ‘BStmt_Jmp e’ >> +Cases_on ‘e’ >> +SIMP_TAC (std_ss++holBACore_ss) [resolved_fail_block_cases] +QED + +Theorem resolve_fail_block_refines_vars: + refines_vars resolve_fail_block +Proof +SIMP_TAC std_ss [refines_vars_def] >> +REPEAT GEN_TAC >> +DISCH_THEN (STRIP_ASSUME_TAC o MATCH_MP resolve_fail_block_sound) >> +ASM_SIMP_TAC (list_ss++PRED_SET_ss) [] >> +PROVE_TAC [resolved_fail_block_vars] +QED + +Definition resolve_fail_def: + resolve_fail p l = replace_block p l resolve_fail_block +End + +Theorem EXISTS_MEM_labels: + ∀l bls. + EXISTS (\bl. bl.bb_label = l) bls ⇒ + MEM l (bir_labels_of_program (BirProgram bls)) +Proof +SIMP_TAC std_ss [bir_labels_of_program_def, MEM_MAP, EXISTS_MEM] >> +PROVE_TAC [] +QED + +Theorem resolve_fail_sound: + ∀p l p'. + resolve_fail p l = SOME p' ⇒ + resolved_fail l (BExp_Const (Imm1 0w)) p p' +Proof +REPEAT GEN_TAC >> +Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> +Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> +SIMP_TAC std_ss [resolve_fail_def] >> +DISCH_THEN (MP_TAC o MATCH_MP replace_block_SOME) >> +STRIP_TAC >> +Q.PAT_X_ASSUM ‘_ = SOME _’ + (STRIP_ASSUME_TAC o MATCH_MP resolve_fail_block_sound) >> +‘bl2.bb_label = l’ by PROVE_TAC [resolved_fail_block_labels] >> + +SIMP_TAC std_ss [resolved_fail_cases] >> +Q.LIST_EXISTS_TAC [‘bl’, ‘bl2’] >> +ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC, APPEND] >> +REPEAT STRIP_TAC >| [ + (*labels*) + ASM_SIMP_TAC list_ss [bir_labels_of_program_def], + + (*Changed block*) + ASM_SIMP_TAC std_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_stop], + ASM_SIMP_TAC std_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_stop], + REV_FULL_SIMP_TAC std_ss [], + + (*Unchanged blocks*) + Cases_on ‘EXISTS (\bl. bl.bb_label = l') bls1’ >- ( + ASM_SIMP_TAC std_ss [bir_get_current_block_append_stop, GSYM IS_SOME_EXISTS, + bir_get_current_block_block_pc_IS_SOME, EXISTS_MEM_labels] + ) >> + + FULL_SIMP_TAC list_ss [combinTheory.o_ABS_R] >> + subgoal ‘MEM l' (bir_labels_of_program (BirProgram bls2))’ >- ( + FULL_SIMP_TAC list_ss [bir_labels_of_program_def, MEM_MAP, EVERY_MEM] >> + PROVE_TAC [] + ) >> + ASM_SIMP_TAC list_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_skip, + GSYM IS_SOME_EXISTS, + bir_get_current_block_block_pc_IS_SOME] +] +QED + +Theorem resolve_fail_simulated_termination: + ∀p l p'. + resolve_fail p l = SOME p' ⇒ + simulated_termination p p' +Proof +PROVE_TAC [resolve_fail_sound, + simulated_fail_simulated_termination, + resolved_fail_simulated_fail] +QED + +Theorem resolve_fail_vars: + ∀p l p'. + resolve_fail p l = SOME p' ⇒ + bir_vars_of_program p' SUBSET bir_vars_of_program p +Proof +PROVE_TAC [resolve_fail_def, replace_block_SOME_vars, + resolve_fail_block_refines_vars] +QED + +(*Sanity check*) +Theorem resolve_fail_contract_transfer: + ∀p l1 p' l ls pre post. + resolve_fail p l1 = SOME p' ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels_triple p' l ls pre post ⇒ + bir_exec_to_labels_triple p l ls pre post +Proof +PROVE_TAC [resolve_fail_simulated_termination, + resolve_fail_vars, contract_transfer] +QED + + +Definition resolve_block_def: + (resolve_block bl v sl = + case bl.bb_last_statement of + BStmt_Jmp (BLE_Exp e) => + if type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) + then SOME [cjmp_block bl.bb_label bl.bb_statements e v sl; + jmp_block sl e] + else NONE + | _ => NONE) +End + +Theorem resolve_block_sound: + ∀bl1 v sl r. + resolve_block bl1 v sl = SOME r ⇒ + (∃bl2 bl3. + r = [bl2; bl3] ∧ + resolved_block (bl1.bb_label) v sl bl1 bl2 bl3) +Proof +REPEAT GEN_TAC >> +Cases_on ‘bl1’ >> rename1 ‘bir_block_t l1 bss es’ >> +Cases_on ‘es’ >> +SIMP_TAC (std_ss++holBACore_ss) [resolve_block_def] >> +rename1 ‘BStmt_Jmp e’ >> +Cases_on ‘e’ >> +SIMP_TAC (list_ss++holBACore_ss) [resolved_block_cases, jmp_block_def] +QED + +Theorem resolve_block_refines_vars: + ∀v sl. refines_vars (\bl. resolve_block bl v sl) +Proof +SIMP_TAC std_ss [refines_vars_def] >> +REPEAT GEN_TAC >> +DISCH_THEN (STRIP_ASSUME_TAC o MATCH_MP resolve_block_sound) >> +IMP_RES_TAC resolved_block_vars >> +ASM_SIMP_TAC (list_ss++PRED_SET_ss) [] +QED + +Definition resolve_def: + resolve p l v sl = replace_block p l (\bl. resolve_block bl v sl) +End + +Theorem resolve_sound: + ∀p l v sl p'. + fresh_label (BL_Label sl) p ⇒ + MEM (BL_Address v) (bir_labels_of_program p) ⇒ + resolve p l v sl = SOME p' ⇒ + resolved l v sl p p' +Proof +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> +Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> +SIMP_TAC std_ss [resolve_def] >> +DISCH_THEN (STRIP_ASSUME_TAC o MATCH_MP replace_block_SOME) >> +FULL_SIMP_TAC std_ss [] >> +Q.PAT_X_ASSUM ‘_ = SOME _’ + (STRIP_ASSUME_TAC o MATCH_MP resolve_block_sound) >> +‘bl2.bb_label = l ∧ bl3.bb_label = BL_Label sl’ + by PROVE_TAC [resolved_block_labels] >> + +SIMP_TAC std_ss [resolved_cases] >> +Q.LIST_EXISTS_TAC [‘bl’, ‘bl2’, ‘bl3’] >> +ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC, APPEND] >> +Q.PAT_X_ASSUM ‘MEM _ _’ (K ALL_TAC) >> (*Removes assumption that interferes with FULL_SIMP_TAC*) +REPEAT STRIP_TAC >| [ + (*labels*) + ASM_SIMP_TAC list_ss [bir_labels_of_program_def] >> + PROVE_TAC [], + + (*Changed block*) + ASM_SIMP_TAC std_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_stop], + ASM_SIMP_TAC std_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_stop], + subgoal ‘EVERY (\bl. bl.bb_label ≠ BL_Label sl) bls1 ∧ + bl2.bb_label ≠ BL_Label sl’ >- ( + FULL_SIMP_TAC list_ss [fresh_label_def, bir_labels_of_program_def, + MEM_MAP, EVERY_MEM] >> + PROVE_TAC [] + ) >> + ASM_SIMP_TAC std_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_skip, + bir_get_current_block_cons_stop], + REV_FULL_SIMP_TAC std_ss [], + + (*Unchanged blocks*) + Cases_on ‘EXISTS (\bl. bl.bb_label = l') bls1’ >- ( + ASM_SIMP_TAC std_ss [bir_get_current_block_append_stop, GSYM IS_SOME_EXISTS, + bir_get_current_block_block_pc_IS_SOME, EXISTS_MEM_labels] + ) >> + + FULL_SIMP_TAC list_ss [combinTheory.o_ABS_R] >> + subgoal ‘MEM l' (bir_labels_of_program (BirProgram bls2))’ >- ( + FULL_SIMP_TAC list_ss [bir_labels_of_program_def, MEM_MAP, EVERY_MEM] >> + PROVE_TAC [] + ) >> + subgoal ‘bl3.bb_label ≠ l'’ >- ( + FULL_SIMP_TAC list_ss [fresh_label_def, bir_labels_of_program_def, MEM_MAP] >> + PROVE_TAC [] + ) >> + ASM_SIMP_TAC list_ss [bir_get_current_block_append_skip, + bir_get_current_block_cons_skip, + GSYM IS_SOME_EXISTS, + bir_get_current_block_block_pc_IS_SOME] +] +QED + +Theorem resolve_simulated_termination: + ∀p l v sl p'. + fresh_label (BL_Label sl) p ⇒ + MEM (BL_Address v) (bir_labels_of_program p) ⇒ + resolve p l v sl = SOME p' ⇒ + simulated_termination p p' +Proof +PROVE_TAC [resolve_sound, + simulated_simulated_termination, + resolved_simulated] +QED + +Theorem resolve_vars: + ∀p l v sl p'. + resolve p l v sl = SOME p' ⇒ + bir_vars_of_program p' SUBSET bir_vars_of_program p +Proof +METIS_TAC [resolve_def, replace_block_SOME_vars, + resolve_block_refines_vars] +QED + +(*Sanity check*) +Theorem resolve_contract_transfer: + ∀sl p v l p' ls pre post. + fresh_label (BL_Label sl) p ⇒ + MEM (BL_Address v) (bir_labels_of_program p) ⇒ + resolve p l v sl = SOME p' ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels_triple p' l ls pre post ⇒ + bir_exec_to_labels_triple p l ls pre post +Proof +PROVE_TAC [resolve_simulated_termination, + resolve_vars, contract_transfer] +QED + + +val _ = export_theory(); + diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml index f36233180..54ec0cc76 100644 --- a/examples/ijr/simulationFailScript.sml +++ b/examples/ijr/simulationFailScript.sml @@ -26,7 +26,7 @@ End Theorem bir_exec_stmsB_assert_cjmp: ∀bss os c s os2 m2 s2 os1 m1 s1. - bir_exec_stmtsB (bss ⧺ [BStmt_Assert (BExp_Const (Imm1 0w))]) (os, c, s) = (os2, m2, s2) ⇒ + bir_exec_stmtsB (bss ++ [BStmt_Assert (BExp_Const (Imm1 0w))]) (os, c, s) = (os2, m2, s2) ⇒ bir_exec_stmtsB bss (os, c, s) = (os1, m1, s1) ⇒ (s1 = s2 ∧ os1 = os2 ∧ m1 = m2 ∧ bir_state_is_terminated s2) ∨ (s2.bst_status = BST_AssertionViolated) diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml index 081493d7a..a1ae145f7 100644 --- a/examples/ijr/simulationScript.sml +++ b/examples/ijr/simulationScript.sml @@ -318,7 +318,7 @@ Theorem bir_exec_block_jmp: MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ ~(bir_state_is_terminated s) ⇒ bir_eval_exp e s.bst_environ = SOME (BVal_Imm v) ⇒ - bl = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ + bl = jmp_block sl e ⇒ (∃s'. bir_exec_block p' bl s = ([], 1, s') ∧ if MEM (BL_Address v) (bir_labels_of_program p) then s' = s with bst_pc := bir_block_pc (BL_Address v) @@ -326,7 +326,7 @@ Theorem bir_exec_block_jmp: Proof REPEAT STRIP_TAC >> FULL_SIMP_TAC (list_ss++holBACore_ss) - [bir_exec_block_def, bir_exec_stmtsB_def, LET_DEF, + [jmp_block_def, bir_exec_block_def, bir_exec_stmtsB_def, LET_DEF, bir_exec_stmtE_def, bir_exec_stmt_jmp_def, bir_eval_label_exp_def, bir_exec_stmt_jmp_to_label_def, bir_state_is_terminated_def] QED @@ -338,7 +338,7 @@ Theorem bir_exec_to_labels_jmp: ~(bir_state_is_terminated s) ⇒ bir_eval_exp e s.bst_environ = SOME (BVal_Imm v) ⇒ - bl = bir_block_t (BL_Label sl) [] (BStmt_Jmp (BLE_Exp e)) ⇒ + bl = jmp_block sl e ⇒ bir_get_current_block p' (s.bst_pc) = SOME bl ⇒ ls = bir_labels_of_program p ⇒ (∃s' n. bir_exec_to_labels (set ls) p' s = BER_Ended [] 1 n s' ∧ @@ -498,7 +498,8 @@ subgoal ‘∃s2' n. bir_exec_to_labels (set ls) p' s2 = BER_Ended [] 1 n s2' s2' = s2 with bst_pc := bir_block_pc (BL_Address v') else s2'.bst_status = BST_JumpOutside (BL_Address v')’ >- ( IRULE_TAC bir_exec_to_labels_jmp >> - FULL_SIMP_TAC (std_ss++holBACore_ss) [resolved_cases] + FULL_SIMP_TAC (std_ss++holBACore_ss) [resolved_cases] >> + METIS_TAC [] ) >> (*Evaluation of e in labels of p*) From 925db6280ee39690f23a47d61f88a15321dd4ddb Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Fri, 23 Apr 2021 16:28:41 +0200 Subject: [PATCH 0049/1015] Add proof producing procedures for naive ijr transformation and contract transfer (#9) * Add definitions of resolve_fully and resolve_fully_n and necessary theorems, in particular, contract transfer theorem * Add proof producing procedures for resolve_fully_n and contract transfer * Remove unnecessary assumption from resolved and change ending statement on resolved_fail * Add examples for resolve_fully, resolve_fully_n and proof producing procedures --- examples/ijr/contractTransferScript.sml | 6 + examples/ijr/examplesScript.sml | 110 ++++++++++++-- examples/ijr/resolutionScript.sml | 12 +- examples/ijr/resolveFullyLib.sml | 38 +++++ examples/ijr/resolveFullyScript.sml | 188 ++++++++++++++++++++++++ examples/ijr/resolveScript.sml | 98 ++++++------ examples/ijr/simulationFailScript.sml | 2 +- examples/ijr/simulationScript.sml | 18 ++- 8 files changed, 398 insertions(+), 74 deletions(-) create mode 100644 examples/ijr/resolveFullyLib.sml create mode 100644 examples/ijr/resolveFullyScript.sml diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index f73f672f5..d704079a0 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -22,6 +22,12 @@ Definition simulated_termination_def: exec_to_prog p s p = BER_Ended o1 m1 n1 s') End +Theorem simulated_termination_REFL: + ∀p. simulated_termination p p +Proof +SIMP_TAC (std_ss++holBACore_ss) [simulated_termination_def] +QED + Theorem simulated_simulated_termination: ∀p p'. simulated p p' ⇒ simulated_termination p p' Proof diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml index 7c2a58403..105029de7 100644 --- a/examples/ijr/examplesScript.sml +++ b/examples/ijr/examplesScript.sml @@ -1,12 +1,18 @@ open HolKernel Parse boolLib bossLib; -open bslSyntax bir_execLib; +open bslSyntax bir_execLib bir_bool_expTheory bir_htSyntax; +open bir_wp_interfaceLib; +open tutorial_smtSupportLib; +open bir_compositionLib; -open resolveTheory; +open resolveTheory resolveFullyTheory; +open resolveFullyLib; val _ = new_theory "examples"; +val _ = bir_ppLib.install_bir_pretty_printers(); + val observe_type = Type `: 'a` val bdefprog_list = bdefprog_list observe_type @@ -14,24 +20,104 @@ val block1 = (blabel_addr32 0, [bassign (bvarimm32 "y", bconst32 4)], (bjmp o belabel_expr o bden o bvarimm32) "y") -val block2: term * term list * term = (blabel_addr32 4, [], (bhalt o bconst32) 0) +val block2: term * term list * term = (blabel_addr32 4, + [], + (bhalt o bconst32) 0) -val prog_def = bdefprog_list "prog" [block1, block2] -val prog = (snd o dest_eq o concl) prog_def -val n_max = 10; -val _ = bir_exec_prog_print "prog" prog n_max NONE NONE NONE; +(*Program definition*) +val prog_def = bdefprog_list "prog" [block1, block2] +val prog_tm = (rhs o concl) prog_def +(*val _ = bir_exec_prog_print "prog" prog_tm 10 NONE NONE NONE;*) -val prog'_def = EVAL “resolve_fail ^prog (BL_Address (Imm32 0w))” -val prog' = (dest_some o snd o dest_eq o concl) prog'_def +val prog_var = mk_var("prog", type_of prog_tm); +val prog_def = Define `^prog_var = ^prog_tm`; +val prog_tm' = (lhs o concl) prog_def -val _ = bir_exec_prog_print "prog'" prog' n_max NONE NONE NONE; -val prog'_def = EVAL “resolve ^prog (BL_Address (Imm32 0w)) (Imm32 10w) "fresh"” -val prog' = (dest_some o snd o dest_eq o concl) prog'_def +(*resolve_fail and resolve tests*) +val prog'_thm = EVAL “resolve_fail ^prog_tm (BL_Address (Imm32 0w)) (Imm32 4w)” +val prog'_tm = (dest_some o rhs o concl) prog'_thm +(*val _ = bir_exec_prog_print "prog'" prog'_tm 10 NONE NONE NONE;*) +val prog'_thm = EVAL “resolve ^prog_tm (BL_Address (Imm32 0w)) (Imm32 10w) "0w-1"” +val prog'_tm = (dest_some o rhs o concl) prog'_thm (*val _ = bir_exec_prog_print "prog'" prog' n_max NONE NONE NONE;*) +(*resolve_fully test*) +val arg1 = “BL_Address (Imm32 0w)” +val arg2 = “[(Imm32 10w, "0w-1"); (Imm32 4w, "0w-2")]” +val arg3 = “Imm32 4w” +val prog'_thm = EVAL “resolve_fully ^prog_tm ^arg1 ^arg2 ^arg3” +val prog'_tm = (dest_some o rhs o concl) prog'_thm + + +(*resolve_fully_n one indirect jump test many steps*) +val args = “[(^arg1, ^arg2, ^arg3)]” +val prog'_thm = EVAL “resolve_fully_n ^prog_tm ^args” +val prog'_tm = (dest_some o rhs o concl) prog'_thm + + +(*resolve_fully_n many indirect jumps many steps test*) +val block1' = (blabel_addr32 8, + [bassign (bvarimm32 "z", bconst32 4)], + (bjmp o belabel_expr o bden o bvarimm32) "z") +val prog2_def = bdefprog_list "prog2" [block1, block2, block1'] +val prog2_tm = (rhs o concl) prog2_def + +val args = “[(^arg1, ^arg2, ^arg3); + (BL_Address (Imm32 8w), [(Imm32 10w, "8w-1"); (Imm32 4w, "8w-2")], ^arg3)]” +val prog2'_thm = EVAL “resolve_fully_n ^prog2_tm ^args” +val prog2'_tm = (dest_some o rhs o concl) prog2'_thm + + +(*contract transfer test*) +(*Transform program*) +val args = “[(BL_Address (Imm32 0w), [(Imm32 4w, "0w-2")], ^arg3)]” +val (prog'_tm, prog'_def, prog'_thm) = resolve_indirect_jumps(prog_tm', args) + +(*Obtain WP contract*) +val pre_def = Define ‘pre = bir_exp_true’; +val post_def = Define ‘post = ^(beq((bden o bvarimm32) "y", bconst32 4))’; + +val prefix = "example_"; +val entry_label_tm = “BL_Address (Imm32 0w)”; +val ending_labels_tm = “{BL_Address (Imm32 4w)}”; +val post_tm = “\l. if (l = BL_Address (Imm32 4w)) + then post + else bir_exp_false”; +val defs = [prog'_def, post_def, bir_exp_false_def]; + +val (ht_thm, wp_tm) = + bir_obtain_ht prog'_tm entry_label_tm + ending_labels_tm ending_set_to_sml_list + post_tm postcond_exp_from_label + prefix defs; + +val wp_def = Define `wp = ^(wp_tm)`; +val ht_thm' = REWRITE_RULE [GSYM wp_def] ht_thm; + +(* +val defs = [prog_def, post_def, bir_exp_true_def, bir_exp_false_def]; +val (ht, wp_tm) = + bir_obtain_ht prog_tm entry_label_tm + ending_labels_tm ending_set_to_sml_list + post_tm postcond_exp_from_label + prefix defs; +*) + +(*Transfer WP contract*) +val ht'_thm = transfer_contract(prog_tm', prog'_thm, ht_thm') + +(*Obtain contract by proving implication*) +val contract_pre = (lhs o concl) pre_def; +val contract_wp = (lhs o concl) wp_def; +val contract_imp = bimp (contract_pre, contract_wp); +val contract_imp_taut_thm = prove_exp_is_taut contract_imp; +val contract = + label_ct_to_simp_ct_predset ht'_thm contract_imp_taut_thm; + + val _ = export_theory(); diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index ed881358f..0cdd105d9 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -62,6 +62,8 @@ FULL_SIMP_TAC (list_ss++PRED_SET_ss++holBACore_ss) bir_vars_of_stmtE_def, bir_vars_of_label_exp_def] QED +(*TODO: maybe these should be Inductive for consistency?*) + Definition direct_jump_target_block_def: direct_jump_target_block l bl = ∀es. @@ -71,11 +73,10 @@ Definition direct_jump_target_block_def: ∃c l1. es = BStmt_CJmp c l1 (BLE_Label l)) End -(*TODO: maybe these should be Inductive for consistency?*) Definition direct_jump_target_def: direct_jump_target l p = ∃l' bl. - bir_get_current_block p (bir_block_pc l') = SOME bl ⇒ + bir_get_current_block p (bir_block_pc l') = SOME bl ∧ direct_jump_target_block l bl End @@ -90,7 +91,6 @@ Inductive resolved: fresh_label (BL_Label sl) p ∧ (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p) ∨ l = BL_Label sl) ∧ - (MEM (BL_Address v) (bir_labels_of_program p)) ∧ bir_get_current_block p (bir_block_pc l1) = SOME bl1 ∧ bir_get_current_block p' (bir_block_pc l1) = SOME bl2 ∧ @@ -109,7 +109,7 @@ Definition assert_block_def: assert_block l bss v = <| bb_label := l; bb_statements := bss ++ [BStmt_Assert (BExp_Const (Imm1 0w))]; - bb_last_statement := BStmt_Halt v |> + bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address v)) |> End Inductive resolved_fail_block: @@ -131,14 +131,14 @@ QED Theorem resolved_fail_block_vars: ∀l v bl1 bl2. - resolved_fail_block l (BExp_Const v) bl1 bl2 ⇒ + resolved_fail_block l v bl1 bl2 ⇒ bir_vars_of_block bl2 SUBSET bir_vars_of_block bl1 Proof REPEAT STRIP_TAC >> FULL_SIMP_TAC (list_ss++PRED_SET_ss++holBACore_ss) [resolved_fail_block_cases, assert_block_def, bir_vars_of_block_def, bir_vars_of_stmtE_def, - bir_vars_of_stmtB_def] + bir_vars_of_stmtB_def, bir_vars_of_label_exp_def] QED Inductive resolved_fail: diff --git a/examples/ijr/resolveFullyLib.sml b/examples/ijr/resolveFullyLib.sml new file mode 100644 index 000000000..b58549353 --- /dev/null +++ b/examples/ijr/resolveFullyLib.sml @@ -0,0 +1,38 @@ +structure resolveFullyLib = +struct +open HolKernel Parse boolLib bossLib; + +open optionSyntax bir_htSyntax; + +open resolveFullyTheory; + +fun resolve_indirect_jumps(prog_tm, args) = + let + val prog'_thm = EVAL “resolve_fully_n ^prog_tm ^args” + val prog'_tm = (dest_some o rhs o concl) prog'_thm + val prog'_var = mk_var("prog'", type_of prog'_tm) + val prog'_def = Define `^prog'_var = ^prog'_tm` + val prog'_tm' = (lhs o concl) prog'_def + val prog'_thm' = REWRITE_RULE [GSYM prog'_def] prog'_thm + in + (prog'_tm', prog'_def, prog'_thm') + end + +fun transfer_contract(prog_tm, prog'_thm, ht_thm) = + let + val ht_tm = concl ht_thm + val (_, entry_tm, exits_tm, _, _) = dest_bir_exec_to_labels_triple ht_tm + val entry_thm = prove ( + “MEM ^entry_tm (bir_labels_of_program ^prog_tm)”, + EVAL_TAC) + val ending_thm = prove ( + “^exits_tm SUBSET (set (bir_labels_of_program ^prog_tm))”, + EVAL_TAC) + val res_thm = MATCH_MP resolve_fully_n_contract_transfer prog'_thm + val res_thm = MATCH_MP res_thm entry_thm + val res_thm = MATCH_MP res_thm ending_thm + in + MATCH_MP res_thm ht_thm + end + +end diff --git a/examples/ijr/resolveFullyScript.sml b/examples/ijr/resolveFullyScript.sml new file mode 100644 index 000000000..8165071e5 --- /dev/null +++ b/examples/ijr/resolveFullyScript.sml @@ -0,0 +1,188 @@ +open HolKernel Parse boolLib bossLib; + +open listTheory optionTheory pred_setTheory pred_setSimps; + +open bir_programTheory bir_program_blocksTheory; +open HolBACoreSimps; + +open resolutionTheory resolveTheory contractTransferTheory; + +val _ = new_theory "resolveFully"; + + +Definition direct_jump_targets_block_compute_def: + direct_jump_targets_block_compute bl = + case bl.bb_last_statement of + BStmt_Jmp (BLE_Label l) => [l] + | BStmt_CJmp e (BLE_Label l1) (BLE_Label l2) => [l1; l2] + | BStmt_CJmp e (BLE_Label l1) _ => [l1] + | BStmt_CJmp e _ (BLE_Label l2) => [l2] + | _ => [] +End + +Theorem direct_jump_target_block_direct_jump_targets_block_compute: + ∀l bl. + direct_jump_target_block l bl ⇒ + MEM l (direct_jump_targets_block_compute bl) +Proof +SIMP_TAC std_ss [direct_jump_target_block_def] >> +REPEAT STRIP_TAC >- ( + ASM_SIMP_TAC (list_ss++bir_TYPES_ss) [direct_jump_targets_block_compute_def] +) >- ( + Cases_on ‘l2’ >> + ASM_SIMP_TAC (list_ss++bir_TYPES_ss) [direct_jump_targets_block_compute_def] +) >> +Cases_on ‘l1’ >> +ASM_SIMP_TAC (list_ss++bir_TYPES_ss) [direct_jump_targets_block_compute_def] +QED + +Definition direct_jump_targets_compute_def: + direct_jump_targets_compute (BirProgram bls) = + LIST_BIND bls direct_jump_targets_block_compute +End + +Theorem direct_jump_target_direct_jump_targets_compute: + ∀l p. direct_jump_target l p ⇒ + MEM l (direct_jump_targets_compute p) +Proof +Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> +SIMP_TAC std_ss [direct_jump_target_def] >> +REPEAT STRIP_TAC >> +SIMP_TAC list_ss [direct_jump_targets_compute_def, LIST_BIND_def, MEM_FLAT, MEM_MAP] >> +Q.EXISTS_TAC ‘direct_jump_targets_block_compute bl’ >> +STRIP_TAC >- ( + Q.EXISTS_TAC ‘bl’ >> + ASM_SIMP_TAC std_ss [MEM_EL] >> + PROVE_TAC [bir_get_program_block_info_by_label_THM, bir_get_current_block_SOME] +) >> + +IMP_RES_TAC direct_jump_target_block_direct_jump_targets_block_compute +QED + +Definition fresh_label_compute_def: + fresh_label_compute l p = + (~(MEM l (bir_labels_of_program p)) ∧ + ~(MEM l (direct_jump_targets_compute p))) +End + +Theorem fresh_label_compute_sound: + ∀l p. fresh_label_compute l p ⇒ fresh_label l p +Proof +SIMP_TAC std_ss [fresh_label_compute_def, fresh_label_def] >> +REPEAT STRIP_TAC >> +PROVE_TAC [direct_jump_target_direct_jump_targets_compute] +QED + +Definition resolve_fully_def: + (resolve_fully p l [] v = resolve_fail p l v) ∧ + (resolve_fully p l ((v, sl) :: xs) v' = + if fresh_label_compute (BL_Label sl) p then + OPTION_BIND (resolve p l v sl) (\p'. resolve_fully p' (BL_Label sl) xs v') + else NONE) +End + +Theorem resolve_fully_simulated_termination: + ∀p l xs v' p'. + resolve_fully p l xs v' = SOME p' ⇒ + simulated_termination p p' +Proof +Induct_on ‘xs’ >> +REPEAT GEN_TAC >- ( + PROVE_TAC [resolve_fully_def, resolve_fail_simulated_termination] +) >> + +rename1 ‘SOME p''’ >> +Cases_on ‘h’ >> rename1 ‘(v, sl)’ >> +SIMP_TAC std_ss [resolve_fully_def] >> +PROVE_TAC [resolve_simulated_termination, fresh_label_compute_sound, + resolve_labels, simulated_termination_transitive] +QED + +Theorem resolve_fully_vars: + ∀p l xs v' p'. + resolve_fully p l xs v' = SOME p' ⇒ + bir_vars_of_program p' SUBSET bir_vars_of_program p +Proof +Induct_on ‘xs’ >> +REPEAT GEN_TAC >- ( + PROVE_TAC [resolve_fully_def, resolve_fail_vars] +) >> + +rename1 ‘SOME p''’ >> +Cases_on ‘h’ >> rename1 ‘(v, sl)’ >> +SIMP_TAC std_ss [resolve_fully_def] >> +PROVE_TAC [resolve_vars, SUBSET_TRANS] +QED + +Theorem resolve_fully_labels: + ∀p l xs v' p'. + resolve_fully p l xs v' = SOME p' ⇒ + set (bir_labels_of_program p) SUBSET set (bir_labels_of_program p') +Proof +Induct_on ‘xs’ >> +REPEAT GEN_TAC >- ( + PROVE_TAC [resolve_fully_def, resolve_fail_labels, SUBSET_REFL] +) >> + +rename1 ‘SOME p''’ >> +Cases_on ‘h’ >> rename1 ‘(v, sl)’ >> +SIMP_TAC std_ss [resolve_fully_def] >> +PROVE_TAC [resolve_labels, SUBSET_TRANS] +QED + +Definition resolve_fully_n_def: + (resolve_fully_n p [] = SOME p) ∧ + (resolve_fully_n p ((l, xs, v) :: ys) = + OPTION_BIND (resolve_fully p l xs v) (\p'. resolve_fully_n p' ys)) +End + +Theorem resolve_fully_n_simulated_termination: + ∀p ys p'. + resolve_fully_n p ys = SOME p' ⇒ + simulated_termination p p' +Proof +Induct_on ‘ys’ >> +REPEAT GEN_TAC >- ( + SIMP_TAC std_ss [resolve_fully_n_def, simulated_termination_REFL] +) >> + +rename1 ‘SOME p''’ >> +Cases_on ‘h’ >> Cases_on ‘r’ >> rename1 ‘(l, xs, v)’ >> +SIMP_TAC std_ss [resolve_fully_n_def] >> +PROVE_TAC [resolve_fully_simulated_termination, + resolve_fully_labels, simulated_termination_transitive] +QED + +Theorem resolve_fully_n_vars: + ∀p ys p'. + resolve_fully_n p ys = SOME p' ⇒ + bir_vars_of_program p' SUBSET bir_vars_of_program p +Proof +Induct_on ‘ys’ >> +REPEAT GEN_TAC >- ( + SIMP_TAC std_ss [resolve_fully_n_def, SUBSET_REFL] +) >> + +rename1 ‘SOME p''’ >> +Cases_on ‘h’ >> Cases_on ‘r’ >> rename1 ‘(l, xs, v)’ >> +SIMP_TAC std_ss [resolve_fully_n_def] >> +PROVE_TAC [resolve_fully_vars, SUBSET_TRANS] +QED + +Theorem resolve_fully_n_contract_transfer: + ∀p ys p' l ls pre post. + resolve_fully_n p ys = SOME p' ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_exec_to_labels_triple p' l ls pre post ⇒ + bir_exec_to_labels_triple p l ls pre post +Proof +PROVE_TAC [resolve_fully_n_simulated_termination, + resolve_fully_n_vars, contract_transfer] +QED + + +val _ = export_theory(); + diff --git a/examples/ijr/resolveScript.sml b/examples/ijr/resolveScript.sml index 5f70fa09e..ef7cee20d 100644 --- a/examples/ijr/resolveScript.sml +++ b/examples/ijr/resolveScript.sml @@ -2,8 +2,7 @@ open HolKernel Parse boolLib bossLib; open listTheory optionTheory pred_setTheory pred_setSimps; -open bir_programTheory bir_expTheory bir_exp_immTheory bir_typing_progTheory; -open bir_program_blocksTheory bir_program_multistep_propsTheory; +open bir_programTheory bir_typing_progTheory bir_program_blocksTheory; open HolBACoreSimps; open resolutionTheory simulationTheory simulationFailTheory contractTransferTheory; @@ -229,18 +228,18 @@ QED Definition resolve_fail_block_def: - (resolve_fail_block bl = + (resolve_fail_block bl v = case bl.bb_last_statement of BStmt_Jmp (BLE_Exp e) => - SOME [assert_block bl.bb_label bl.bb_statements (BExp_Const (Imm1 0w))] + SOME [assert_block bl.bb_label bl.bb_statements v] | _ => NONE) End Theorem resolve_fail_block_sound: - ∀bl1 r. - resolve_fail_block bl1 = SOME r ⇒ + ∀bl1 v r. + resolve_fail_block bl1 v = SOME r ⇒ (∃bl2. r = [bl2] ∧ - resolved_fail_block (bl1.bb_label) (BExp_Const (Imm1 0w)) bl1 bl2) + resolved_fail_block (bl1.bb_label) v bl1 bl2) Proof REPEAT GEN_TAC >> Cases_on ‘bl1’ >> @@ -253,7 +252,7 @@ SIMP_TAC (std_ss++holBACore_ss) [resolved_fail_block_cases] QED Theorem resolve_fail_block_refines_vars: - refines_vars resolve_fail_block + ∀v. refines_vars (\bl. resolve_fail_block bl v) Proof SIMP_TAC std_ss [refines_vars_def] >> REPEAT GEN_TAC >> @@ -263,7 +262,7 @@ PROVE_TAC [resolved_fail_block_vars] QED Definition resolve_fail_def: - resolve_fail p l = replace_block p l resolve_fail_block + resolve_fail p l v = replace_block p l (\bl. resolve_fail_block bl v) End Theorem EXISTS_MEM_labels: @@ -276,16 +275,16 @@ PROVE_TAC [] QED Theorem resolve_fail_sound: - ∀p l p'. - resolve_fail p l = SOME p' ⇒ - resolved_fail l (BExp_Const (Imm1 0w)) p p' + ∀p l p' v. + resolve_fail p l v = SOME p' ⇒ + resolved_fail l v p p' Proof REPEAT GEN_TAC >> Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> SIMP_TAC std_ss [resolve_fail_def] >> DISCH_THEN (MP_TAC o MATCH_MP replace_block_SOME) >> -STRIP_TAC >> +BETA_TAC >> STRIP_TAC >> Q.PAT_X_ASSUM ‘_ = SOME _’ (STRIP_ASSUME_TAC o MATCH_MP resolve_fail_block_sound) >> ‘bl2.bb_label = l’ by PROVE_TAC [resolved_fail_block_labels] >> @@ -323,8 +322,8 @@ REPEAT STRIP_TAC >| [ QED Theorem resolve_fail_simulated_termination: - ∀p l p'. - resolve_fail p l = SOME p' ⇒ + ∀p l v p'. + resolve_fail p l v = SOME p' ⇒ simulated_termination p p' Proof PROVE_TAC [resolve_fail_sound, @@ -333,27 +332,30 @@ PROVE_TAC [resolve_fail_sound, QED Theorem resolve_fail_vars: - ∀p l p'. - resolve_fail p l = SOME p' ⇒ + ∀p l v p'. + resolve_fail p l v = SOME p' ⇒ bir_vars_of_program p' SUBSET bir_vars_of_program p Proof -PROVE_TAC [resolve_fail_def, replace_block_SOME_vars, +METIS_TAC [resolve_fail_def, replace_block_SOME_vars, resolve_fail_block_refines_vars] QED -(*Sanity check*) -Theorem resolve_fail_contract_transfer: - ∀p l1 p' l ls pre post. - resolve_fail p l1 = SOME p' ⇒ - - MEM l (bir_labels_of_program p) ⇒ - ls SUBSET (set (bir_labels_of_program p)) ⇒ - - bir_exec_to_labels_triple p' l ls pre post ⇒ - bir_exec_to_labels_triple p l ls pre post +Theorem resolve_fail_labels: + ∀p l v p'. + resolve_fail p l v = SOME p' ⇒ + bir_labels_of_program p = bir_labels_of_program p' Proof -PROVE_TAC [resolve_fail_simulated_termination, - resolve_fail_vars, contract_transfer] +REPEAT GEN_TAC >> +Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> +Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> +SIMP_TAC std_ss [resolve_fail_def] >> +DISCH_THEN (MP_TAC o MATCH_MP replace_block_SOME) >> +BETA_TAC >> STRIP_TAC >> + +IMP_RES_TAC resolve_fail_block_sound >> +‘bl2.bb_label = l’ by PROVE_TAC [resolved_fail_block_labels] >> +ASM_SIMP_TAC std_ss [Once (GSYM APPEND_ASSOC), APPEND] >> +ASM_SIMP_TAC list_ss [bir_labels_of_program_def] QED @@ -401,11 +403,10 @@ End Theorem resolve_sound: ∀p l v sl p'. fresh_label (BL_Label sl) p ⇒ - MEM (BL_Address v) (bir_labels_of_program p) ⇒ resolve p l v sl = SOME p' ⇒ resolved l v sl p p' Proof -REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> +REPEAT GEN_TAC >> STRIP_TAC >> Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> SIMP_TAC std_ss [resolve_def] >> @@ -419,7 +420,6 @@ Q.PAT_X_ASSUM ‘_ = SOME _’ SIMP_TAC std_ss [resolved_cases] >> Q.LIST_EXISTS_TAC [‘bl’, ‘bl2’, ‘bl3’] >> ASM_SIMP_TAC std_ss [GSYM APPEND_ASSOC, APPEND] >> -Q.PAT_X_ASSUM ‘MEM _ _’ (K ALL_TAC) >> (*Removes assumption that interferes with FULL_SIMP_TAC*) REPEAT STRIP_TAC >| [ (*labels*) ASM_SIMP_TAC list_ss [bir_labels_of_program_def] >> @@ -466,7 +466,6 @@ QED Theorem resolve_simulated_termination: ∀p l v sl p'. fresh_label (BL_Label sl) p ⇒ - MEM (BL_Address v) (bir_labels_of_program p) ⇒ resolve p l v sl = SOME p' ⇒ simulated_termination p p' Proof @@ -484,23 +483,26 @@ METIS_TAC [resolve_def, replace_block_SOME_vars, resolve_block_refines_vars] QED -(*Sanity check*) -Theorem resolve_contract_transfer: - ∀sl p v l p' ls pre post. - fresh_label (BL_Label sl) p ⇒ - MEM (BL_Address v) (bir_labels_of_program p) ⇒ +Theorem resolve_labels: + ∀p l v sl p'. resolve p l v sl = SOME p' ⇒ - - MEM l (bir_labels_of_program p) ⇒ - ls SUBSET (set (bir_labels_of_program p)) ⇒ - - bir_exec_to_labels_triple p' l ls pre post ⇒ - bir_exec_to_labels_triple p l ls pre post + set (bir_labels_of_program p) SUBSET set (bir_labels_of_program p') Proof -PROVE_TAC [resolve_simulated_termination, - resolve_vars, contract_transfer] +REPEAT GEN_TAC >> +Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> +Cases_on ‘p'’ >> rename1 ‘SOME (BirProgram p')’ >> +SIMP_TAC std_ss [resolve_def] >> +DISCH_THEN (STRIP_ASSUME_TAC o MATCH_MP replace_block_SOME) >> +ASM_SIMP_TAC (list_ss++PRED_SET_ss) [bir_labels_of_program_def] >> +STRIP_TAC >- ( + SIMP_TAC (std_ss++PRED_SET_ss) [SUBSET_DEF] +) >> + +FULL_SIMP_TAC std_ss [] >> +IMP_RES_TAC resolve_block_sound >> +ASM_SIMP_TAC list_ss [] >> +PROVE_TAC [resolved_block_labels] QED val _ = export_theory(); - diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml index 54ec0cc76..0cd874be8 100644 --- a/examples/ijr/simulationFailScript.sml +++ b/examples/ijr/simulationFailScript.sml @@ -63,7 +63,7 @@ ASM_SIMP_TAC (std_ss++holBACore_ss) [assert_block_def, bir_exec_block_def] >> by PROVE_TAC [pairTheory.PAIR] >> ‘∃os1 m1 s1. bir_exec_stmtsB bss ([],0,s) = (os1, m1, s1)’ by PROVE_TAC [pairTheory.PAIR] >> -Q.ABBREV_TAC ‘s2' = bir_exec_stmtE p' (BStmt_Halt v) s2’ >> +Q.ABBREV_TAC ‘s2' = bir_exec_stmtE p' (BStmt_Jmp (BLE_Label (BL_Address v))) s2’ >> Q.ABBREV_TAC ‘s1' = bir_exec_stmtE p (BStmt_Jmp (BLE_Exp e)) s1’ >> FULL_SIMP_TAC std_ss [LET_DEF] >> diff --git a/examples/ijr/simulationScript.sml b/examples/ijr/simulationScript.sml index a1ae145f7..45b634261 100644 --- a/examples/ijr/simulationScript.sml +++ b/examples/ijr/simulationScript.sml @@ -192,7 +192,6 @@ Theorem bir_exec_stmtE_cjmp_jmp: ∀p' p sl es1 e c v es2 s s2 s1. (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ - MEM (BL_Address v) (bir_labels_of_program p) ⇒ type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ⇒ es1 = BStmt_Jmp (BLE_Exp e) ⇒ @@ -203,11 +202,11 @@ Theorem bir_exec_stmtE_cjmp_jmp: bir_exec_stmtE p es1 s = s1 ⇒ (s1 = s2 ∨ jump_fresh e s s2 sl s1 p) Proof -REPEAT GEN_TAC >> NTAC 3 STRIP_TAC >> +REPEAT GEN_TAC >> NTAC 2 STRIP_TAC >> SIMP_TAC (std_ss++holBACore_ss) [cjmp_stmtE_def, bir_exec_stmtE_def, bir_exec_stmt_cjmp_def, LET_DEF] >> NTAC 2 (DISCH_THEN (K ALL_TAC)) >> -rename1 ‘MEM (BL_Address v') _’ >> +rename1 ‘_ = SOME (BType_Imm (type_of_bir_imm v'))’ >> (*e not well typed*) Cases_on ‘bir_eval_exp e s.bst_environ’ >- ( @@ -234,6 +233,10 @@ ASM_SIMP_TAC std_ss [] >- ( FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_bin_pred_Equal_REWR, bir_exec_stmt_jmp_def, bir_eval_label_exp_def] >> + subgoal ‘MEM (BL_Address v') (bir_labels_of_program p') ⇔ + MEM (BL_Address v') (bir_labels_of_program p)’ >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) [] + ) >> PROVE_TAC [bir_exec_stmt_jmp_to_label_same] ) >> @@ -257,7 +260,6 @@ Theorem bir_exec_block_cjmp_jmp: (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p) ∨ l = (BL_Label sl)) ⇒ ~(direct_jump_target_block (BL_Label sl) bl1) ⇒ - MEM (BL_Address v) (bir_labels_of_program p) ⇒ type_of_bir_exp e = SOME (BType_Imm (type_of_bir_imm v)) ⇒ bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ⇒ @@ -268,7 +270,7 @@ Theorem bir_exec_block_cjmp_jmp: (s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ (jump_fresh e (exec_stmtsB bss s) s2 sl s1 p) Proof -REPEAT GEN_TAC >> NTAC 4 STRIP_TAC >> +REPEAT GEN_TAC >> NTAC 3 STRIP_TAC >> rename1 ‘bir_exec_block p' _ _= (os2', m2', s2')’ >> rename1 ‘bir_exec_block p _ _ = (os1', m1', s1')’ >> @@ -420,7 +422,8 @@ REVERSE (Cases_on ‘l = l1’) >- ( Q.SUBGOAL_THEN ‘s2 = s1 ∧ os2 = os1 ∧ m2 = m1’ (fn thm => SIMP_TAC std_ss [thm]) >- ( MP_TAC (Q.SPECL [‘p'’, ‘p’, ‘{sl}’, ‘bl’, ‘s’, ‘s2’, ‘os2’, ‘m2’] bir_exec_block_same) >> FULL_SIMP_TAC (std_ss++PRED_SET_ss) - [resolved_cases, fresh_label_def, direct_jump_target_def] + [resolved_cases, fresh_label_def, direct_jump_target_def] >> + PROVE_TAC [] ) >> (*Programs fail*) @@ -460,7 +463,8 @@ subgoal ‘(s1 = s2 ∧ os1 = os2 ∧ m1 = m2) ∨ IRULE_TAC bir_exec_block_cjmp_jmp >> Q.LIST_EXISTS_TAC [‘bl1’, ‘bl2’, ‘l1’, ‘p'’, ‘v’] >> FULL_SIMP_TAC std_ss [resolved_cases, fresh_label_def, - direct_jump_target_def, resolved_block_cases] + direct_jump_target_def, resolved_block_cases] >> + PROVE_TAC [] ) >- ( (*Programs execute block labelled l1 with same result*) NTAC 3 (POP_ASSUM (fn thm => SIMP_TAC std_ss [GSYM thm])) >> From b72e56daa3cf1e477eac341b5e259c8321659877 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Tue, 11 May 2021 08:45:00 +0200 Subject: [PATCH 0050/1015] Add evaluation using synthetic BIR programs and nonworking C program evaluation (#10) * Add evaluation using synthetic BIR programs * Add nonworking evaluation using C program --- examples/ijr/Makefile | 18 +++ examples/ijr/composition.c | 16 +++ examples/ijr/composition.da | 48 ++++++++ examples/ijr/evaluation.sml | 104 ++++++++++++++++ examples/ijr/examplesScript.sml | 200 ++++++++++++++++++------------- examples/ijr/generationLib.sml | 106 ++++++++++++++++ examples/ijr/plot.py | 38 ++++++ examples/ijr/resolveFullyLib.sml | 27 ++++- 8 files changed, 475 insertions(+), 82 deletions(-) create mode 100644 examples/ijr/Makefile create mode 100644 examples/ijr/composition.c create mode 100644 examples/ijr/composition.da create mode 100644 examples/ijr/evaluation.sml create mode 100644 examples/ijr/generationLib.sml create mode 100755 examples/ijr/plot.py diff --git a/examples/ijr/Makefile b/examples/ijr/Makefile new file mode 100644 index 000000000..9ff9f89b3 --- /dev/null +++ b/examples/ijr/Makefile @@ -0,0 +1,18 @@ +# For compilation and disassembling +HOLBA_DIR = ../.. +include $(HOLBA_DIR)/scripts/setup/env_check_gcc_arm8.mk +CROSS =$(HOLBA_GCC_ARM8_CROSS) +CFLAGS_BAREMETAL = -Iinc -ggdb3 -std=gnu99 -Wall -fno-builtin # -O1 + +.DEFAULT_GOAL := all +all: + # Count + wc -l resolveFullyLib.sml + wc -l resolveFullyScript.sml resolveScript.sml resolutionScript.sml simulationScript.sml simulationFailScript.sml contractTransferScript.sml + # Run + make --directory=../.. examples/ijr/evaluation.sml_run + # Plot + python3 plot.py + # Compile and disassemble c evaluation program + ${CROSS}gcc -DBAREMETAL= ${CFLAGS_BAREMETAL} -c -o composition.o -fno-stack-protector composition.c + ${CROSS}objdump -d composition.o > composition.da \ No newline at end of file diff --git a/examples/ijr/composition.c b/examples/ijr/composition.c new file mode 100644 index 000000000..319d581cf --- /dev/null +++ b/examples/ijr/composition.c @@ -0,0 +1,16 @@ + +int addOne(int x) { + return x + 1; +} + +int addTwo(int x) { + return x + 2; +} + +int comp(int (*f)(int), int (*g)(int), int x) { + return (*f) ((*g) (x)); +} + +int addThree(int x) { + return comp(&addOne, &addTwo, x); +} diff --git a/examples/ijr/composition.da b/examples/ijr/composition.da new file mode 100644 index 000000000..715b7c968 --- /dev/null +++ b/examples/ijr/composition.da @@ -0,0 +1,48 @@ + +composition.o: file format elf64-littleaarch64 + + +Disassembly of section .text: + +0000000000000000 : + 0: d10043ff sub sp, sp, #0x10 + 4: b9000fe0 str w0, [sp, #12] + 8: b9400fe0 ldr w0, [sp, #12] + c: 11000400 add w0, w0, #0x1 + 10: 910043ff add sp, sp, #0x10 + 14: d65f03c0 ret + +0000000000000018 : + 18: d10043ff sub sp, sp, #0x10 + 1c: b9000fe0 str w0, [sp, #12] + 20: b9400fe0 ldr w0, [sp, #12] + 24: 11000800 add w0, w0, #0x2 + 28: 910043ff add sp, sp, #0x10 + 2c: d65f03c0 ret + +0000000000000030 : + 30: a9bd7bfd stp x29, x30, [sp, #-48]! + 34: 910003fd mov x29, sp + 38: f90017e0 str x0, [sp, #40] + 3c: f90013e1 str x1, [sp, #32] + 40: b9001fe2 str w2, [sp, #28] + 44: f94013e1 ldr x1, [sp, #32] + 48: b9401fe0 ldr w0, [sp, #28] + 4c: d63f0020 blr x1 + 50: f94017e1 ldr x1, [sp, #40] + 54: d63f0020 blr x1 + 58: a8c37bfd ldp x29, x30, [sp], #48 + 5c: d65f03c0 ret + +0000000000000060 : + 60: a9be7bfd stp x29, x30, [sp, #-32]! + 64: 910003fd mov x29, sp + 68: b9001fe0 str w0, [sp, #28] + 6c: b9401fe2 ldr w2, [sp, #28] + 70: 90000000 adrp x0, 18 + 74: 91000001 add x1, x0, #0x0 + 78: 90000000 adrp x0, 0 + 7c: 91000000 add x0, x0, #0x0 + 80: 94000000 bl 30 + 84: a8c27bfd ldp x29, x30, [sp], #32 + 88: d65f03c0 ret diff --git a/examples/ijr/evaluation.sml b/examples/ijr/evaluation.sml new file mode 100644 index 000000000..9e433b5ae --- /dev/null +++ b/examples/ijr/evaluation.sml @@ -0,0 +1,104 @@ +open HolKernel Parse boolLib bossLib; + +open resolveFullyLib; +open generationLib; + +fun timer_start () = Time.now(); +fun timer_stop tm = (Time.- (Time.now(), tm)); +fun timer_stop_str tm = Time.toString (Time.- (Time.now(), tm)); + +fun test_resolve_indirect_jumps(middle_blocks_n) = + let + val exit_addr = 10 * middle_blocks_n + val prog_def = gen_program("prog", middle_blocks_n) + val prog_tm = (lhs o concl) prog_def + val args = gen_args_program(middle_blocks_n, 1) + val start = timer_start() + val (prog'_tm, prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) + val stop = timer_stop start + in + (middle_blocks_n, stop) + end + +fun test_partial_resolve_indirect_jumps(middle_blocks_n) = + let + val exit_addr = 10 * middle_blocks_n + val prog_def = gen_program("prog", middle_blocks_n) + val prog_tm = (lhs o concl) prog_def + val args = gen_partial_args_program(middle_blocks_n, 100) + val start = timer_start() + val (prog'_tm, prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) + val stop = timer_stop start + in + (middle_blocks_n, stop) + end + +fun test_transfer_contract (middle_blocks_n) = + let + val exit_addr = 10 * middle_blocks_n + val prog_def = gen_program("prog", middle_blocks_n) + val prog_tm = (lhs o concl) prog_def + + val prog'_thm = prove(“resolve_fully_n prog args = SOME prog'”, cheat) + + val entry_label_tm = “BL_Label "entry1"” + val ending_labels_tm = “{^(blabel_addr64 exit_addr)}” + val post_tm = “\l. if (l = ^(blabel_addr64 exit_addr)) + then bir_exp_true + else bir_exp_false” + val ht_thm' = prove( + “bir_exec_to_labels_triple prog' ^entry_label_tm ^ending_labels_tm bir_exp_true ^post_tm”, + cheat) + + val start = timer_start() + val ht'_thm = transfer_contract(prog_tm, prog'_thm, ht_thm') + val stop = timer_stop start + in + (middle_blocks_n, stop) + end + +fun print_test_result(middle_blocks_n, time) = + let + val res = "size: " ^ Int.toString middle_blocks_n ^ + ", time: " ^ Time.toString(time) ^ "s\n" + in + print(res) + end + +fun write_test_result file (n, time) = + TextIO.output (file, Int.toString n ^ ", " ^ Time.toString(time) ^ "\n") + +fun write_test_results(filename, results) = + let + val file = TextIO.openOut (filename) + val _ = List.map (write_test_result file) results + in + TextIO.closeOut file + end; + +fun range(start, step, stop) = + List.tabulate(((stop-start) div step) + 1, fn i => start + step * i) + +fun linspace(start, n, stop) = range(start, (stop - start) div n, stop) + + +(*200 64s*) +val resolve_middle_blocks_ns = range(10, 10, 200) +val resolve_results = List.map (test_resolve_indirect_jumps) resolve_middle_blocks_ns +val _ = List.map print_test_result resolve_results +val _ = write_test_results("resolve", resolve_results) + +(*val _ = Posix.Process.sleep (Time.fromSeconds (Int.toLarge 60))*) + +val partial_resolve_middle_blocks_ns = range(100, 100, 2000) +val partial_resolve_results = List.map (test_partial_resolve_indirect_jumps) partial_resolve_middle_blocks_ns +val _ = List.map print_test_result partial_resolve_results +val _ = write_test_results("partial_resolve", partial_resolve_results) + +(*val _ = Posix.Process.sleep (Time.fromSeconds (Int.toLarge 60))*) + +(*80000 53s*) +val transfer_middle_blocks_ns = range(1000, 2000, 38000) +val transfer_results = List.map test_transfer_contract transfer_middle_blocks_ns +val _ = List.map print_test_result transfer_results +val _ = write_test_results("transfer", transfer_results) diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml index 105029de7..a68756e33 100644 --- a/examples/ijr/examplesScript.sml +++ b/examples/ijr/examplesScript.sml @@ -1,123 +1,163 @@ open HolKernel Parse boolLib bossLib; -open bslSyntax bir_execLib bir_bool_expTheory bir_htSyntax; -open bir_wp_interfaceLib; -open tutorial_smtSupportLib; -open bir_compositionLib; +open bslSyntax listSyntax; +open bir_execLib bir_bool_expTheory; +open bir_lifter_interfaceLib; -open resolveTheory resolveFullyTheory; -open resolveFullyLib; +open resolveFullyLib generationLib; val _ = new_theory "examples"; val _ = bir_ppLib.install_bir_pretty_printers(); -val observe_type = Type `: 'a` -val bdefprog_list = bdefprog_list observe_type +val block1 = (blabel_addr64 0, + [bassign (bvarimm64 "y", bconst64 4)], + (bjmp o belabel_expr o bden o bvarimm64) "y") -val block1 = (blabel_addr32 0, - [bassign (bvarimm32 "y", bconst32 4)], - (bjmp o belabel_expr o bden o bvarimm32) "y") - -val block2: term * term list * term = (blabel_addr32 4, +val block2: term * term list * term = (blabel_addr64 4, [], - (bhalt o bconst32) 0) + (bhalt o bconst64) 0) (*Program definition*) val prog_def = bdefprog_list "prog" [block1, block2] -val prog_tm = (rhs o concl) prog_def -(*val _ = bir_exec_prog_print "prog" prog_tm 10 NONE NONE NONE;*) - -val prog_var = mk_var("prog", type_of prog_tm); -val prog_def = Define `^prog_var = ^prog_tm`; -val prog_tm' = (lhs o concl) prog_def - +val prog_tm = (lhs o concl) prog_def (*resolve_fail and resolve tests*) -val prog'_thm = EVAL “resolve_fail ^prog_tm (BL_Address (Imm32 0w)) (Imm32 4w)” -val prog'_tm = (dest_some o rhs o concl) prog'_thm -(*val _ = bir_exec_prog_print "prog'" prog'_tm 10 NONE NONE NONE;*) +val resolve_fail_prog'_thm = EVAL “resolve_fail ^prog_tm (BL_Address (Imm64 0w)) (Imm64 4w)” +val resolve_fail_prog'_tm = (dest_some o rhs o concl) resolve_fail_prog'_thm -val prog'_thm = EVAL “resolve ^prog_tm (BL_Address (Imm32 0w)) (Imm32 10w) "0w-1"” -val prog'_tm = (dest_some o rhs o concl) prog'_thm -(*val _ = bir_exec_prog_print "prog'" prog' n_max NONE NONE NONE;*) +val resolve_prog'_thm = EVAL “resolve ^prog_tm (BL_Address (Imm64 0w)) (Imm64 10w) "0w-1"” +val resolve_prog'_tm = (dest_some o rhs o concl) resolve_prog'_thm (*resolve_fully test*) -val arg1 = “BL_Address (Imm32 0w)” -val arg2 = “[(Imm32 10w, "0w-1"); (Imm32 4w, "0w-2")]” -val arg3 = “Imm32 4w” -val prog'_thm = EVAL “resolve_fully ^prog_tm ^arg1 ^arg2 ^arg3” -val prog'_tm = (dest_some o rhs o concl) prog'_thm +val arg1 = “BL_Address (Imm64 0w)” +val arg2 = “[(Imm64 10w, "0w-1"); (Imm64 4w, "0w-2")]” +val arg3 = “Imm64 4w” +val resolve_fully_prog'_thm = EVAL “resolve_fully ^prog_tm ^arg1 ^arg2 ^arg3” +val resolve_fully_prog'_tm = (dest_some o rhs o concl) resolve_fully_prog'_thm (*resolve_fully_n one indirect jump test many steps*) -val args = “[(^arg1, ^arg2, ^arg3)]” -val prog'_thm = EVAL “resolve_fully_n ^prog_tm ^args” -val prog'_tm = (dest_some o rhs o concl) prog'_thm +val resolve_fully_n_args = “[(^arg1, ^arg2, ^arg3)]” +val resolve_fully_n_prog'_thm = EVAL “resolve_fully_n ^prog_tm ^resolve_fully_n_args” +val resolve_fully_n_prog'_tm = (dest_some o rhs o concl) resolve_fully_n_prog'_thm (*resolve_fully_n many indirect jumps many steps test*) -val block1' = (blabel_addr32 8, - [bassign (bvarimm32 "z", bconst32 4)], - (bjmp o belabel_expr o bden o bvarimm32) "z") +val block1' = (blabel_addr64 8, + [bassign (bvarimm64 "z", bconst64 4)], + (bjmp o belabel_expr o bden o bvarimm64) "z") val prog2_def = bdefprog_list "prog2" [block1, block2, block1'] val prog2_tm = (rhs o concl) prog2_def -val args = “[(^arg1, ^arg2, ^arg3); - (BL_Address (Imm32 8w), [(Imm32 10w, "8w-1"); (Imm32 4w, "8w-2")], ^arg3)]” -val prog2'_thm = EVAL “resolve_fully_n ^prog2_tm ^args” +val prog2_args = “[(^arg1, ^arg2, ^arg3); + (BL_Address (Imm64 8w), [(Imm64 10w, "8w-1"); (Imm64 4w, "8w-2")], ^arg3)]” +val prog2'_thm = EVAL “resolve_fully_n ^prog2_tm ^prog2_args” val prog2'_tm = (dest_some o rhs o concl) prog2'_thm -(*contract transfer test*) +(*resolve_indirect_jumps and transfer_contract test*) (*Transform program*) -val args = “[(BL_Address (Imm32 0w), [(Imm32 4w, "0w-2")], ^arg3)]” -val (prog'_tm, prog'_def, prog'_thm) = resolve_indirect_jumps(prog_tm', args) +val small_args = “[(BL_Address (Imm64 0w), [(Imm64 4w, "0w-2")], ^arg3)]” +val (small_prog'_tm, small_prog'_def, small_prog'_thm) = + resolve_indirect_jumps("resolved_small_prog", prog_tm, small_args) (*Obtain WP contract*) -val pre_def = Define ‘pre = bir_exp_true’; -val post_def = Define ‘post = ^(beq((bden o bvarimm32) "y", bconst32 4))’; - -val prefix = "example_"; -val entry_label_tm = “BL_Address (Imm32 0w)”; -val ending_labels_tm = “{BL_Address (Imm32 4w)}”; -val post_tm = “\l. if (l = BL_Address (Imm32 4w)) +val pre_def = Define ‘pre = bir_exp_true’ +val post_def = Define ‘post = ^(beq((bden o bvarimm64) "y", bconst64 4))’ +val prefix = "example1_" +val pre_tm = (lhs o concl) pre_def +val entry_label_tm = “BL_Address (Imm64 0w)” +val ending_labels_tm = “{BL_Address (Imm64 4w)}” +val post_tm = “\l. if (l = BL_Address (Imm64 4w)) then post - else bir_exp_false”; -val defs = [prog'_def, post_def, bir_exp_false_def]; - -val (ht_thm, wp_tm) = - bir_obtain_ht prog'_tm entry_label_tm - ending_labels_tm ending_set_to_sml_list - post_tm postcond_exp_from_label - prefix defs; - -val wp_def = Define `wp = ^(wp_tm)`; -val ht_thm' = REWRITE_RULE [GSYM wp_def] ht_thm; - -(* -val defs = [prog_def, post_def, bir_exp_true_def, bir_exp_false_def]; -val (ht, wp_tm) = - bir_obtain_ht prog_tm entry_label_tm - ending_labels_tm ending_set_to_sml_list - post_tm postcond_exp_from_label - prefix defs; -*) + else bir_exp_false” +val defs = [small_prog'_def, post_def, bir_exp_false_def] + +val small_contract = prove_and_transfer_contract(prog_tm, small_prog'_tm, small_prog'_thm, + prefix, pre_tm, entry_label_tm, + ending_labels_tm, post_tm, defs) + + +(*Larger resolve_indirect_jumps and transfer_contract test*) +val middle_blocks_n = 10; +val exit_addr = 10 * middle_blocks_n +val large_prog_def = gen_program("prog", middle_blocks_n) +val large_prog_tm = (lhs o concl) large_prog_def + +val large_prog_args = gen_args_program(middle_blocks_n, 1) +val (large_prog'_tm, large_prog'_def, large_prog'_thm) = + resolve_indirect_jumps("resolved_large_prog", large_prog_tm, large_prog_args) + +val pre_def = Define ‘pre = ^(blt((bden o bvarimm64) "x", (bconst64 middle_blocks_n)))’ +val post_def = Define ‘post = ^(beq((bden o bvarimm64) "y", bconst64 exit_addr))’ +val prefix = "example2_" +val pre_tm = (lhs o concl) pre_def +val entry_label_tm = “BL_Label "entry1"” +val ending_labels_tm = “{^(blabel_addr64 exit_addr)}” +val post_tm = “\l. if (l = ^(blabel_addr64 exit_addr)) + then post + else bir_exp_false” +val defs = [large_prog'_def, post_def, bir_exp_false_def, bir_exp_true_def] + +val large_contract = prove_and_transfer_contract(large_prog_tm, large_prog'_tm, large_prog'_thm, + prefix, pre_tm, entry_label_tm, + ending_labels_tm, post_tm, defs) +(*c test*) +val _ = lift_da_and_store "composition" + "composition.da" + ((Arbnum.fromInt 0), (Arbnum.fromInt 0x1000000)); + +fun eval tm = (snd o dest_eq o concl o EVAL) tm -(*Transfer WP contract*) -val ht'_thm = transfer_contract(prog_tm', prog'_thm, ht_thm') +val blocks = (fst o dest_list o dest_BirProgram o eval) “bir_composition_prog” -(*Obtain contract by proving implication*) -val contract_pre = (lhs o concl) pre_def; -val contract_wp = (lhs o concl) wp_def; -val contract_imp = bimp (contract_pre, contract_wp); -val contract_imp_taut_thm = prove_exp_is_taut contract_imp; -val contract = - label_ct_to_simp_ct_predset ht'_thm contract_imp_taut_thm; +val wtf = el 33 blocks +val endings = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks +val add_one_ret = el 6 blocks +val add_two_ret = el 12 blocks +val call_add_one = el 20 blocks +val call_add_two = el 22 blocks +val comp_ret = el 24 blocks +val add_two_three = el 35 blocks + +(*Transform program*) +val add_one_ret_args = [(blabel_addr64 20, [80], ["20w-1"], 80)] +val add_two_ret_args = [(blabel_addr64 44, [88], ["44w-1"], 88)] +val call_add_one_args = [(blabel_addr64 76, [0], ["76w-1"], 0)] +val call_add_two_args = [(blabel_addr64 84, [24], ["84w-1"], 24)] +val comp_ret_args = [(blabel_addr64 92, [132], ["92w-1"], 132)] +val composition_args = gen_args (add_one_ret_args @ + add_two_ret_args @ + call_add_one_args @ + call_add_two_args @ + comp_ret_args) +val (cprog'_tm, cprog'_def, cprog'_thm) = + resolve_indirect_jumps("resolved_composition_prog", “bir_composition_prog”, composition_args) + +val blocks' = (fst o dest_list o dest_BirProgram o eval) cprog'_tm +val endings' = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks' + +(*Obtain WP contract*) +(*val pre_def = Define ‘pre = bir_exp_true’ +val post_def = Define ‘post = bir_exp_true’ +val prefix = "example3_" +val pre_tm = (lhs o concl) pre_def +val entry_label_tm = “BL_Address (Imm64 96w)” +val ending_labels_tm = “{BL_Address (Imm64 136w)}” +val post_tm = “\l. if (l = BL_Address (Imm64 136w)) + then post + else bir_exp_false” +val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] + +val ccontract = prove_and_transfer_contract(“bir_composition_prog”, cprog'_tm, cprog'_thm, + prefix, pre_tm, entry_label_tm, + ending_labels_tm, post_tm, defs) +*) val _ = export_theory(); diff --git a/examples/ijr/generationLib.sml b/examples/ijr/generationLib.sml new file mode 100644 index 000000000..8d4f690ed --- /dev/null +++ b/examples/ijr/generationLib.sml @@ -0,0 +1,106 @@ +structure generationLib = +struct + +open HolKernel Parse boolLib bossLib; + +open listSyntax pairSyntax stringSyntax; +open bir_execLib bslSyntax bir_immSyntax wordsSyntax; + +val observe_type = Type `: 'a` +val bdefprog_list = bdefprog_list observe_type + +fun entry_block1(middle_blocks_n, exit_addr): term * term list * term = + (blabel_str "entry1", + [], + bcjmp (blt((bden o bvarimm64) "x", (bconst64 middle_blocks_n)), + belabel_str "entry2", + belabel_addr64 exit_addr)) + +val entry_block2: term * term list * term = + (blabel_str "entry2", + [], + (bjmp o belabel_expr o bden o bvarimm64) "x") + +fun middle_block(addr, exit_addr): term * term list * term = + (blabel_addr64 addr, + [bassign (bvarimm64 "y", bconst64 exit_addr)], + (bjmp o belabel_expr o bden o bvarimm64) "y") + +fun middle_blocks(addrs, exit_addr) = + List.map (fn addr => middle_block(addr, exit_addr)) addrs + +fun exit_block(addr): term * term list * term = + (blabel_addr64 addr, + [], + (bhalt o bconst64) 0) + +fun gen_program(name, middle_blocks_n) = + let + val exit_addr = middle_blocks_n*10; + val addrs = List.tabulate(middle_blocks_n, fn i => i); + val blocks = [entry_block1(middle_blocks_n, exit_addr), entry_block2] @ + middle_blocks(addrs, exit_addr) @ + [exit_block(exit_addr)] + in + bdefprog_list name blocks + end + +fun gen_label_strings(prefix, n) = + List.tabulate(n, (fn i => prefix ^ "-" ^ Int.toString(i + 1))) + +fun gen_arg2(ns, ss) = + let + val fsts = List.map (mk_Imm_of_int 64) ns; + val snds = List.map (fromMLstring) ss; + val list = List.map mk_pair (ListPair.zip(fsts, snds)) + in + mk_list(list, “:(bir_imm_t#string)”) + end + +fun gen_arg(label, ns, ss, exit_addr) = + mk_pair(label, mk_pair(gen_arg2(ns, ss), mk_Imm_of_int 64 exit_addr)) + +fun gen_args(xs) = + let + val ty = “:(bir_label_t # ((bir_imm_t#string) list) # bir_imm_t)” + in + mk_list(List.map gen_arg xs, ty) + end + +fun gen_args_entry_block2(middle_blocks_n) = + let + val targets = List.tabulate(middle_blocks_n, fn i => i); + val fresh_labels = gen_label_strings("entry2", middle_blocks_n); + in + [(blabel_str "entry2", targets, fresh_labels, middle_blocks_n - 1)] + end + +fun gen_args_middle_block(addr, exit_addr, m) = + let + val targets = List.tabulate(m, fn _ => exit_addr); + val fresh_labels = gen_label_strings(Int.toString(addr)^"w", m); + in + [(blabel_addr64 addr, targets, fresh_labels, exit_addr)] + end + +fun gen_args_middle_blocks(addrs, exit_addr, m) = + List.concat (List.map (fn addr => gen_args_middle_block(addr, exit_addr, m)) addrs) + +fun gen_args_program(middle_blocks_n, m) = + let + val addrs = List.tabulate(middle_blocks_n, fn i => i) + val exit_address = middle_blocks_n*10 + in + gen_args (gen_args_entry_block2(middle_blocks_n) @ + gen_args_middle_blocks(addrs, exit_address, m)) + end + +fun gen_partial_args_program(middle_blocks_n, m) = + let + val addrs = List.rev (List.tabulate(m, fn i => middle_blocks_n - 1 - i)) + val exit_address = middle_blocks_n*10 + in + gen_args (gen_args_middle_blocks(addrs, exit_address, 1)) + end + +end diff --git a/examples/ijr/plot.py b/examples/ijr/plot.py new file mode 100755 index 000000000..9f99c8a28 --- /dev/null +++ b/examples/ijr/plot.py @@ -0,0 +1,38 @@ +#!/usr/bin/python3 +import numpy as np +import matplotlib.pyplot as plt + +resolve = np.genfromtxt('resolve', delimiter=',', names=['size', 'time']) + +plt.plot(resolve['size'], resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic programs') +plt.xlabel('Program size (middle blocks)') +plt.ylabel('Time (seconds)') +plt.title('resolve_indirect_jumps benchmark') +plt.legend() +plt.savefig('resolve.png') + +plt.figure() + + +partial_resolve = np.genfromtxt('partial_resolve', delimiter=',', names=['size', 'time']) + +plt.plot(partial_resolve['size'], partial_resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic programs') +plt.xlabel('Program size (middle blocks)') +plt.ylabel('Time (seconds)') +plt.title('resolve_indirect_jumps benchmark') +plt.legend() +plt.savefig('partial_resolve.png') + +plt.figure() + + +transfer = np.genfromtxt('transfer', delimiter=',', names=['size', 'time']) + +plt.plot(transfer['size'], transfer['time'], label='Execution time for transfer_contract on synthetic programs') +plt.xlabel('Program size (middle blocks)') +plt.ylabel('Time (seconds)') +plt.title('transfer_contract benchmark') +plt.legend() +plt.savefig('transfer.png') + +plt.show() diff --git a/examples/ijr/resolveFullyLib.sml b/examples/ijr/resolveFullyLib.sml index b58549353..5b5c78bf6 100644 --- a/examples/ijr/resolveFullyLib.sml +++ b/examples/ijr/resolveFullyLib.sml @@ -4,13 +4,17 @@ open HolKernel Parse boolLib bossLib; open optionSyntax bir_htSyntax; +open bir_wp_interfaceLib; +open tutorial_smtSupportLib; +open bir_compositionLib; + open resolveFullyTheory; -fun resolve_indirect_jumps(prog_tm, args) = +fun resolve_indirect_jumps(prog'_name, prog_tm, args) = let val prog'_thm = EVAL “resolve_fully_n ^prog_tm ^args” val prog'_tm = (dest_some o rhs o concl) prog'_thm - val prog'_var = mk_var("prog'", type_of prog'_tm) + val prog'_var = mk_var(prog'_name, type_of prog'_tm) val prog'_def = Define `^prog'_var = ^prog'_tm` val prog'_tm' = (lhs o concl) prog'_def val prog'_thm' = REWRITE_RULE [GSYM prog'_def] prog'_thm @@ -35,4 +39,23 @@ fun transfer_contract(prog_tm, prog'_thm, ht_thm) = MATCH_MP res_thm ht_thm end +fun prove_and_transfer_contract(prog_tm, prog'_tm, prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) = + let + val (ht_thm, wp_tm) = + bir_obtain_ht + prog'_tm entry_label_tm + ending_labels_tm ending_set_to_sml_list + post_tm postcond_exp_from_label + prefix defs; + val wp_var = mk_var(prefix ^ "_wp", type_of wp_tm) + val wp_def = Define `^(wp_var) = ^(wp_tm)` + val ht_thm' = REWRITE_RULE [GSYM wp_def] ht_thm + (*Transfer WP contract*) + val ht'_thm = transfer_contract(prog_tm, prog'_thm, ht_thm') + val contract_imp = bimp (pre_tm, (lhs o concl) wp_def) + val contract_imp_taut_thm = prove_exp_is_taut contract_imp + in + label_ct_to_simp_ct_predset ht'_thm contract_imp_taut_thm + end + end From f1f55c087f573f545e36faae8b60fedebc12741d Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Wed, 12 May 2021 10:25:55 +0200 Subject: [PATCH 0051/1015] Fix C program evaluation --- examples/ijr/Makefile | 7 +-- examples/ijr/composition.da | 80 ++++++++++++++++----------------- examples/ijr/examplesScript.sml | 53 ++++++++++++++-------- 3 files changed, 79 insertions(+), 61 deletions(-) diff --git a/examples/ijr/Makefile b/examples/ijr/Makefile index 9ff9f89b3..60b39a889 100644 --- a/examples/ijr/Makefile +++ b/examples/ijr/Makefile @@ -9,10 +9,11 @@ all: # Count wc -l resolveFullyLib.sml wc -l resolveFullyScript.sml resolveScript.sml resolutionScript.sml simulationScript.sml simulationFailScript.sml contractTransferScript.sml - # Run + # Run synthetic evaluation make --directory=../.. examples/ijr/evaluation.sml_run # Plot python3 plot.py - # Compile and disassemble c evaluation program + # Compile, link and disassemble c evaluation program ${CROSS}gcc -DBAREMETAL= ${CFLAGS_BAREMETAL} -c -o composition.o -fno-stack-protector composition.c - ${CROSS}objdump -d composition.o > composition.da \ No newline at end of file + ${CROSS}ld -o composition.ld composition.o + ${CROSS}objdump -d composition.ld > composition.da \ No newline at end of file diff --git a/examples/ijr/composition.da b/examples/ijr/composition.da index 715b7c968..72af79b9b 100644 --- a/examples/ijr/composition.da +++ b/examples/ijr/composition.da @@ -1,48 +1,48 @@ -composition.o: file format elf64-littleaarch64 +composition.ld: file format elf64-littleaarch64 Disassembly of section .text: -0000000000000000 : - 0: d10043ff sub sp, sp, #0x10 - 4: b9000fe0 str w0, [sp, #12] - 8: b9400fe0 ldr w0, [sp, #12] - c: 11000400 add w0, w0, #0x1 - 10: 910043ff add sp, sp, #0x10 - 14: d65f03c0 ret +0000000000400000 : + 400000: d10043ff sub sp, sp, #0x10 + 400004: b9000fe0 str w0, [sp, #12] + 400008: b9400fe0 ldr w0, [sp, #12] + 40000c: 11000400 add w0, w0, #0x1 + 400010: 910043ff add sp, sp, #0x10 + 400014: d65f03c0 ret -0000000000000018 : - 18: d10043ff sub sp, sp, #0x10 - 1c: b9000fe0 str w0, [sp, #12] - 20: b9400fe0 ldr w0, [sp, #12] - 24: 11000800 add w0, w0, #0x2 - 28: 910043ff add sp, sp, #0x10 - 2c: d65f03c0 ret +0000000000400018 : + 400018: d10043ff sub sp, sp, #0x10 + 40001c: b9000fe0 str w0, [sp, #12] + 400020: b9400fe0 ldr w0, [sp, #12] + 400024: 11000800 add w0, w0, #0x2 + 400028: 910043ff add sp, sp, #0x10 + 40002c: d65f03c0 ret -0000000000000030 : - 30: a9bd7bfd stp x29, x30, [sp, #-48]! - 34: 910003fd mov x29, sp - 38: f90017e0 str x0, [sp, #40] - 3c: f90013e1 str x1, [sp, #32] - 40: b9001fe2 str w2, [sp, #28] - 44: f94013e1 ldr x1, [sp, #32] - 48: b9401fe0 ldr w0, [sp, #28] - 4c: d63f0020 blr x1 - 50: f94017e1 ldr x1, [sp, #40] - 54: d63f0020 blr x1 - 58: a8c37bfd ldp x29, x30, [sp], #48 - 5c: d65f03c0 ret +0000000000400030 : + 400030: a9bd7bfd stp x29, x30, [sp, #-48]! + 400034: 910003fd mov x29, sp + 400038: f90017e0 str x0, [sp, #40] + 40003c: f90013e1 str x1, [sp, #32] + 400040: b9001fe2 str w2, [sp, #28] + 400044: f94013e1 ldr x1, [sp, #32] + 400048: b9401fe0 ldr w0, [sp, #28] + 40004c: d63f0020 blr x1 + 400050: f94017e1 ldr x1, [sp, #40] + 400054: d63f0020 blr x1 + 400058: a8c37bfd ldp x29, x30, [sp], #48 + 40005c: d65f03c0 ret -0000000000000060 : - 60: a9be7bfd stp x29, x30, [sp, #-32]! - 64: 910003fd mov x29, sp - 68: b9001fe0 str w0, [sp, #28] - 6c: b9401fe2 ldr w2, [sp, #28] - 70: 90000000 adrp x0, 18 - 74: 91000001 add x1, x0, #0x0 - 78: 90000000 adrp x0, 0 - 7c: 91000000 add x0, x0, #0x0 - 80: 94000000 bl 30 - 84: a8c27bfd ldp x29, x30, [sp], #32 - 88: d65f03c0 ret +0000000000400060 : + 400060: a9be7bfd stp x29, x30, [sp, #-32]! + 400064: 910003fd mov x29, sp + 400068: b9001fe0 str w0, [sp, #28] + 40006c: b9401fe2 ldr w2, [sp, #28] + 400070: 90000000 adrp x0, 400000 + 400074: 91006001 add x1, x0, #0x18 + 400078: 90000000 adrp x0, 400000 + 40007c: 91000000 add x0, x0, #0x0 + 400080: 97ffffec bl 400030 + 400084: a8c27bfd ldp x29, x30, [sp], #32 + 400088: d65f03c0 ret diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml index a68756e33..1883c43c1 100644 --- a/examples/ijr/examplesScript.sml +++ b/examples/ijr/examplesScript.sml @@ -1,6 +1,6 @@ open HolKernel Parse boolLib bossLib; -open bslSyntax listSyntax; +open bslSyntax listSyntax wordsSyntax; open bir_execLib bir_bool_expTheory; open bir_lifter_interfaceLib; @@ -115,8 +115,6 @@ fun eval tm = (snd o dest_eq o concl o EVAL) tm val blocks = (fst o dest_list o dest_BirProgram o eval) “bir_composition_prog” -val wtf = el 33 blocks - val endings = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks val add_one_ret = el 6 blocks val add_two_ret = el 12 blocks @@ -125,17 +123,35 @@ val call_add_two = el 22 blocks val comp_ret = el 24 blocks val add_two_three = el 35 blocks +fun addr_to_int addr = (dest_word_literal o snd o gen_dest_Imm o dest_BL_Address) addr + +val add_one_entry_address = (#1 o dest_bir_block o el 1) blocks +val add_one_ret_address = (#1 o dest_bir_block o el 6) blocks +val add_two_entry_address = (#1 o dest_bir_block o el 7) blocks +val add_two_ret_address = (#1 o dest_bir_block o el 12) blocks + +val call_add_one_address = (#1 o dest_bir_block o el 20) blocks +val call_add_one_next_address = (#1 o dest_bir_block o el 21) blocks +val call_add_two_address = (#1 o dest_bir_block o el 22) blocks +val call_add_two_next_address = (#1 o dest_bir_block o el 23) blocks + +val comp_entry_address = (#1 o dest_bir_block o el 13) blocks +val comp_ret_address = (#1 o dest_bir_block o el 24) blocks +val call_comp_next_adress = (#1 o dest_bir_block o el 34) blocks + + (*Transform program*) -val add_one_ret_args = [(blabel_addr64 20, [80], ["20w-1"], 80)] -val add_two_ret_args = [(blabel_addr64 44, [88], ["44w-1"], 88)] -val call_add_one_args = [(blabel_addr64 76, [0], ["76w-1"], 0)] -val call_add_two_args = [(blabel_addr64 84, [24], ["84w-1"], 24)] -val comp_ret_args = [(blabel_addr64 92, [132], ["92w-1"], 132)] -val composition_args = gen_args (add_one_ret_args @ - add_two_ret_args @ - call_add_one_args @ +val add_two_ret_args = [(add_two_ret_address, [0x400050], ["0x400014w-1"], 0x400084)] +val add_one_ret_args = [(add_one_ret_address, [0x400058], ["0x40002Cw-1"], 0x400084)] +val call_add_two_args = [(call_add_two_address, [0x400000], ["0x40004Cw-1"], 0x400084)] +val call_add_one_args = [(call_add_one_address, [0x400018], ["0x400054w-1"], 0x400084)] +val comp_ret_args = [(comp_ret_address, [0x400084], ["0x40005Cw-1"], 0x400084)] + +val composition_args = gen_args (add_two_ret_args @ + add_one_ret_args @ call_add_two_args @ - comp_ret_args) + call_add_one_args @ + comp_ret_args ) val (cprog'_tm, cprog'_def, cprog'_thm) = resolve_indirect_jumps("resolved_composition_prog", “bir_composition_prog”, composition_args) @@ -143,13 +159,14 @@ val blocks' = (fst o dest_list o dest_BirProgram o eval) cprog'_tm val endings' = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks' (*Obtain WP contract*) -(*val pre_def = Define ‘pre = bir_exp_true’ +val get_sp = bden (bvar "SP_EL0" “(BType_Imm Bit64)”) +val pre_def = Define ‘pre = ^(beq(get_sp, bconst64 0xE0000000))’ val post_def = Define ‘post = bir_exp_true’ -val prefix = "example3_" +val prefix = "example3" val pre_tm = (lhs o concl) pre_def -val entry_label_tm = “BL_Address (Imm64 96w)” -val ending_labels_tm = “{BL_Address (Imm64 136w)}” -val post_tm = “\l. if (l = BL_Address (Imm64 136w)) +val entry_label_tm = “BL_Address (Imm64 0x400070w)” +val ending_labels_tm = “{BL_Address (Imm64 0x400084w)}” +val post_tm = “\l. if (l = BL_Address (Imm64 0x400084w)) then post else bir_exp_false” val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] @@ -157,7 +174,7 @@ val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] val ccontract = prove_and_transfer_contract(“bir_composition_prog”, cprog'_tm, cprog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) -*) + val _ = export_theory(); From a9581978c3c271f57aef8c55bae68be1777d3d30 Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Wed, 12 May 2021 11:09:50 +0200 Subject: [PATCH 0052/1015] Finalise C program evaluation --- examples/ijr/Makefile | 20 ++++++--- examples/ijr/evaluation.sml | 5 +-- examples/ijr/examplesScript.sml | 69 -------------------------------- examples/ijr/resolveFullyLib.sml | 17 +++++++- 4 files changed, 30 insertions(+), 81 deletions(-) diff --git a/examples/ijr/Makefile b/examples/ijr/Makefile index 60b39a889..577c5ef69 100644 --- a/examples/ijr/Makefile +++ b/examples/ijr/Makefile @@ -5,15 +5,23 @@ CROSS =$(HOLBA_GCC_ARM8_CROSS) CFLAGS_BAREMETAL = -Iinc -ggdb3 -std=gnu99 -Wall -fno-builtin # -O1 .DEFAULT_GOAL := all -all: - # Count +all: build evalc evalbir + +build: + # Count lines for proof-producing procedures and verified function wc -l resolveFullyLib.sml wc -l resolveFullyScript.sml resolveScript.sml resolutionScript.sml simulationScript.sml simulationFailScript.sml contractTransferScript.sml + # Compile, link and disassemble C evaluation program + ${CROSS}gcc -DBAREMETAL= ${CFLAGS_BAREMETAL} -c -o composition.o -fno-stack-protector composition.c + ${CROSS}ld -o composition.ld composition.o + ${CROSS}objdump -d composition.ld > composition.da + +evalc: + # Run C program evaluation + make --directory=../.. examples/ijr/cProgEvaluation.sml_run + +evalbir: # Run synthetic evaluation make --directory=../.. examples/ijr/evaluation.sml_run # Plot python3 plot.py - # Compile, link and disassemble c evaluation program - ${CROSS}gcc -DBAREMETAL= ${CFLAGS_BAREMETAL} -c -o composition.o -fno-stack-protector composition.c - ${CROSS}ld -o composition.ld composition.o - ${CROSS}objdump -d composition.ld > composition.da \ No newline at end of file diff --git a/examples/ijr/evaluation.sml b/examples/ijr/evaluation.sml index 9e433b5ae..adb29a035 100644 --- a/examples/ijr/evaluation.sml +++ b/examples/ijr/evaluation.sml @@ -2,10 +2,7 @@ open HolKernel Parse boolLib bossLib; open resolveFullyLib; open generationLib; - -fun timer_start () = Time.now(); -fun timer_stop tm = (Time.- (Time.now(), tm)); -fun timer_stop_str tm = Time.toString (Time.- (Time.now(), tm)); +open timersLib; fun test_resolve_indirect_jumps(middle_blocks_n) = let diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml index 1883c43c1..bfef170d7 100644 --- a/examples/ijr/examplesScript.sml +++ b/examples/ijr/examplesScript.sml @@ -2,7 +2,6 @@ open HolKernel Parse boolLib bossLib; open bslSyntax listSyntax wordsSyntax; open bir_execLib bir_bool_expTheory; -open bir_lifter_interfaceLib; open resolveFullyLib generationLib; @@ -106,74 +105,6 @@ val defs = [large_prog'_def, post_def, bir_exp_false_def, bir_exp_true_def] val large_contract = prove_and_transfer_contract(large_prog_tm, large_prog'_tm, large_prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) -(*c test*) -val _ = lift_da_and_store "composition" - "composition.da" - ((Arbnum.fromInt 0), (Arbnum.fromInt 0x1000000)); - -fun eval tm = (snd o dest_eq o concl o EVAL) tm - -val blocks = (fst o dest_list o dest_BirProgram o eval) “bir_composition_prog” - -val endings = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks -val add_one_ret = el 6 blocks -val add_two_ret = el 12 blocks -val call_add_one = el 20 blocks -val call_add_two = el 22 blocks -val comp_ret = el 24 blocks -val add_two_three = el 35 blocks - -fun addr_to_int addr = (dest_word_literal o snd o gen_dest_Imm o dest_BL_Address) addr - -val add_one_entry_address = (#1 o dest_bir_block o el 1) blocks -val add_one_ret_address = (#1 o dest_bir_block o el 6) blocks -val add_two_entry_address = (#1 o dest_bir_block o el 7) blocks -val add_two_ret_address = (#1 o dest_bir_block o el 12) blocks - -val call_add_one_address = (#1 o dest_bir_block o el 20) blocks -val call_add_one_next_address = (#1 o dest_bir_block o el 21) blocks -val call_add_two_address = (#1 o dest_bir_block o el 22) blocks -val call_add_two_next_address = (#1 o dest_bir_block o el 23) blocks - -val comp_entry_address = (#1 o dest_bir_block o el 13) blocks -val comp_ret_address = (#1 o dest_bir_block o el 24) blocks -val call_comp_next_adress = (#1 o dest_bir_block o el 34) blocks - - -(*Transform program*) -val add_two_ret_args = [(add_two_ret_address, [0x400050], ["0x400014w-1"], 0x400084)] -val add_one_ret_args = [(add_one_ret_address, [0x400058], ["0x40002Cw-1"], 0x400084)] -val call_add_two_args = [(call_add_two_address, [0x400000], ["0x40004Cw-1"], 0x400084)] -val call_add_one_args = [(call_add_one_address, [0x400018], ["0x400054w-1"], 0x400084)] -val comp_ret_args = [(comp_ret_address, [0x400084], ["0x40005Cw-1"], 0x400084)] - -val composition_args = gen_args (add_two_ret_args @ - add_one_ret_args @ - call_add_two_args @ - call_add_one_args @ - comp_ret_args ) -val (cprog'_tm, cprog'_def, cprog'_thm) = - resolve_indirect_jumps("resolved_composition_prog", “bir_composition_prog”, composition_args) - -val blocks' = (fst o dest_list o dest_BirProgram o eval) cprog'_tm -val endings' = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks' - -(*Obtain WP contract*) -val get_sp = bden (bvar "SP_EL0" “(BType_Imm Bit64)”) -val pre_def = Define ‘pre = ^(beq(get_sp, bconst64 0xE0000000))’ -val post_def = Define ‘post = bir_exp_true’ -val prefix = "example3" -val pre_tm = (lhs o concl) pre_def -val entry_label_tm = “BL_Address (Imm64 0x400070w)” -val ending_labels_tm = “{BL_Address (Imm64 0x400084w)}” -val post_tm = “\l. if (l = BL_Address (Imm64 0x400084w)) - then post - else bir_exp_false” -val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] - -val ccontract = prove_and_transfer_contract(“bir_composition_prog”, cprog'_tm, cprog'_thm, - prefix, pre_tm, entry_label_tm, - ending_labels_tm, post_tm, defs) val _ = export_theory(); diff --git a/examples/ijr/resolveFullyLib.sml b/examples/ijr/resolveFullyLib.sml index 5b5c78bf6..2cf9f7fb1 100644 --- a/examples/ijr/resolveFullyLib.sml +++ b/examples/ijr/resolveFullyLib.sml @@ -9,6 +9,7 @@ open tutorial_smtSupportLib; open bir_compositionLib; open resolveFullyTheory; +open timersLib; fun resolve_indirect_jumps(prog'_name, prog_tm, args) = let @@ -41,21 +42,33 @@ fun transfer_contract(prog_tm, prog'_thm, ht_thm) = fun prove_and_transfer_contract(prog_tm, prog'_tm, prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) = let + val wp_start = timer_start () + (*Obtain WP contract*) val (ht_thm, wp_tm) = bir_obtain_ht prog'_tm entry_label_tm ending_labels_tm ending_set_to_sml_list post_tm postcond_exp_from_label - prefix defs; + prefix defs + val _ = print ("WP time: " ^ timer_stop_str wp_start ^ "\n") + val wp_var = mk_var(prefix ^ "_wp", type_of wp_tm) val wp_def = Define `^(wp_var) = ^(wp_tm)` val ht_thm' = REWRITE_RULE [GSYM wp_def] ht_thm + (*Transfer WP contract*) + val transfer_start = timer_start () val ht'_thm = transfer_contract(prog_tm, prog'_thm, ht_thm') + val _ = print ("Transfer time: " ^ timer_stop_str transfer_start ^ "\n") + + (*Prove implication using SMT solvers*) + val smt_start = timer_start () val contract_imp = bimp (pre_tm, (lhs o concl) wp_def) val contract_imp_taut_thm = prove_exp_is_taut contract_imp + val res = label_ct_to_simp_ct_predset ht'_thm contract_imp_taut_thm + val _ = print ("SMT time: " ^ timer_stop_str smt_start ^ "\n") in - label_ct_to_simp_ct_predset ht'_thm contract_imp_taut_thm + res end end From 3240520a67adc218511e873aba5a1350d13bcca1 Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Wed, 12 May 2021 11:11:50 +0200 Subject: [PATCH 0053/1015] Add missing files --- examples/ijr/cProgEvaluation.sml | 82 ++++++++++++++++++++++++++++++++ examples/ijr/timersLib.sml | 8 ++++ 2 files changed, 90 insertions(+) create mode 100644 examples/ijr/cProgEvaluation.sml create mode 100644 examples/ijr/timersLib.sml diff --git a/examples/ijr/cProgEvaluation.sml b/examples/ijr/cProgEvaluation.sml new file mode 100644 index 000000000..66b6e687a --- /dev/null +++ b/examples/ijr/cProgEvaluation.sml @@ -0,0 +1,82 @@ +open HolKernel Parse boolLib bossLib; + +open bir_lifter_interfaceLib; +open bir_execLib bir_bool_expTheory; + +open resolveFullyLib; +open generationLib; +open timersLib; + +val lift_start = timer_start () +val _ = lift_da_and_store "composition" + "composition.da" + ((Arbnum.fromInt 0), (Arbnum.fromInt 0x1000000)) +val _ = print ("Lifting time: " ^ timer_stop_str lift_start ^ "\n") + + +fun eval tm = (snd o dest_eq o concl o EVAL) tm + +val blocks = (fst o dest_list o dest_BirProgram o eval) “bir_composition_prog” + +val endings = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks +val add_one_ret = el 6 blocks +val add_two_ret = el 12 blocks +val call_add_one = el 20 blocks +val call_add_two = el 22 blocks +val comp_ret = el 24 blocks +val add_two_three = el 35 blocks + +fun addr_to_int addr = (dest_word_literal o snd o gen_dest_Imm o dest_BL_Address) addr + +val add_one_entry_address = (#1 o dest_bir_block o el 1) blocks +val add_one_ret_address = (#1 o dest_bir_block o el 6) blocks +val add_two_entry_address = (#1 o dest_bir_block o el 7) blocks +val add_two_ret_address = (#1 o dest_bir_block o el 12) blocks + +val call_add_one_address = (#1 o dest_bir_block o el 20) blocks +val call_add_one_next_address = (#1 o dest_bir_block o el 21) blocks +val call_add_two_address = (#1 o dest_bir_block o el 22) blocks +val call_add_two_next_address = (#1 o dest_bir_block o el 23) blocks + +val comp_entry_address = (#1 o dest_bir_block o el 13) blocks +val comp_ret_address = (#1 o dest_bir_block o el 24) blocks +val call_comp_next_adress = (#1 o dest_bir_block o el 34) blocks + + +(*Transform program*) +val add_two_ret_args = [(add_two_ret_address, [0x400050], ["0x400014w-1"], 0x400084)] +val add_one_ret_args = [(add_one_ret_address, [0x400058], ["0x40002Cw-1"], 0x400084)] +val call_add_two_args = [(call_add_two_address, [0x400000], ["0x40004Cw-1"], 0x400084)] +val call_add_one_args = [(call_add_one_address, [0x400018], ["0x400054w-1"], 0x400084)] +val comp_ret_args = [(comp_ret_address, [0x400084], ["0x40005Cw-1"], 0x400084)] + +val composition_args = gen_args (add_two_ret_args @ + add_one_ret_args @ + call_add_two_args @ + call_add_one_args @ + comp_ret_args ) + +val transfer_start = timer_start () +val (cprog'_tm, cprog'_def, cprog'_thm) = + resolve_indirect_jumps("resolved_composition_prog", “bir_composition_prog”, composition_args) +val _ = print ("Transfer time: " ^ timer_stop_str transfer_start ^ "\n") + +val blocks' = (fst o dest_list o dest_BirProgram o eval) cprog'_tm +val endings' = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks' + +(*Obtain WP contract*) +val get_sp = bden (bvar "SP_EL0" “(BType_Imm Bit64)”) +val pre_def = Define ‘pre = ^(beq(get_sp, bconst64 0xE0000000))’ +val post_def = Define ‘post = bir_exp_true’ +val prefix = "example3" +val pre_tm = (lhs o concl) pre_def +val entry_label_tm = “BL_Address (Imm64 0x400070w)” +val ending_labels_tm = “{BL_Address (Imm64 0x400084w)}” +val post_tm = “\l. if (l = BL_Address (Imm64 0x400084w)) + then post + else bir_exp_false” +val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] + +val ccontract = prove_and_transfer_contract(“bir_composition_prog”, cprog'_tm, cprog'_thm, + prefix, pre_tm, entry_label_tm, + ending_labels_tm, post_tm, defs) \ No newline at end of file diff --git a/examples/ijr/timersLib.sml b/examples/ijr/timersLib.sml new file mode 100644 index 000000000..285a163f2 --- /dev/null +++ b/examples/ijr/timersLib.sml @@ -0,0 +1,8 @@ +structure timersLib = +struct + +fun timer_start () = Time.now() +fun timer_stop tm = (Time.- (Time.now(), tm)) +fun timer_stop_str tm = Time.toString (Time.- (Time.now(), tm)) + +end \ No newline at end of file From 91a865dcc8ee5ba339d1c7a8a6db90fdead7db7b Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Fri, 14 May 2021 15:28:03 +0200 Subject: [PATCH 0054/1015] Change evaluation logging in C program evaluation --- examples/ijr/cProgEvaluation.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/ijr/cProgEvaluation.sml b/examples/ijr/cProgEvaluation.sml index 66b6e687a..d15010cbd 100644 --- a/examples/ijr/cProgEvaluation.sml +++ b/examples/ijr/cProgEvaluation.sml @@ -59,7 +59,7 @@ val composition_args = gen_args (add_two_ret_args @ val transfer_start = timer_start () val (cprog'_tm, cprog'_def, cprog'_thm) = resolve_indirect_jumps("resolved_composition_prog", “bir_composition_prog”, composition_args) -val _ = print ("Transfer time: " ^ timer_stop_str transfer_start ^ "\n") +val _ = print ("Resolve time: " ^ timer_stop_str transfer_start ^ "\n") val blocks' = (fst o dest_list o dest_BirProgram o eval) cprog'_tm val endings' = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks' @@ -79,4 +79,4 @@ val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] val ccontract = prove_and_transfer_contract(“bir_composition_prog”, cprog'_tm, cprog'_thm, prefix, pre_tm, entry_label_tm, - ending_labels_tm, post_tm, defs) \ No newline at end of file + ending_labels_tm, post_tm, defs) From 34c4a1040b5c91d2d698e604e937310b292f0857 Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Mon, 24 May 2021 17:47:10 +0200 Subject: [PATCH 0055/1015] Change Makefile --- examples/ijr/Makefile | 3 +++ 1 file changed, 3 insertions(+) diff --git a/examples/ijr/Makefile b/examples/ijr/Makefile index 577c5ef69..e3c5af1df 100644 --- a/examples/ijr/Makefile +++ b/examples/ijr/Makefile @@ -11,6 +11,9 @@ build: # Count lines for proof-producing procedures and verified function wc -l resolveFullyLib.sml wc -l resolveFullyScript.sml resolveScript.sml resolutionScript.sml simulationScript.sml simulationFailScript.sml contractTransferScript.sml + wc -l cProgEvaluation.sml + wc -l generationLib.sml evaluation.sml + wc -l examplesScript.sml # Compile, link and disassemble C evaluation program ${CROSS}gcc -DBAREMETAL= ${CFLAGS_BAREMETAL} -c -o composition.o -fno-stack-protector composition.c ${CROSS}ld -o composition.ld composition.o From cebd0dd968fba5fcb2c898e68399f4841cb9d75f Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Wed, 26 May 2021 11:45:50 +0200 Subject: [PATCH 0056/1015] Remove unecessary arguments and returns values from proof-producing procedures --- examples/ijr/cProgEvaluation.sml | 6 +++--- examples/ijr/evaluation.sml | 6 +++--- examples/ijr/examplesScript.sml | 8 ++++---- examples/ijr/resolveFullyLib.sml | 10 ++++++---- 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/examples/ijr/cProgEvaluation.sml b/examples/ijr/cProgEvaluation.sml index d15010cbd..5ee799938 100644 --- a/examples/ijr/cProgEvaluation.sml +++ b/examples/ijr/cProgEvaluation.sml @@ -57,11 +57,11 @@ val composition_args = gen_args (add_two_ret_args @ comp_ret_args ) val transfer_start = timer_start () -val (cprog'_tm, cprog'_def, cprog'_thm) = +val (cprog'_def, cprog'_thm) = resolve_indirect_jumps("resolved_composition_prog", “bir_composition_prog”, composition_args) val _ = print ("Resolve time: " ^ timer_stop_str transfer_start ^ "\n") -val blocks' = (fst o dest_list o dest_BirProgram o eval) cprog'_tm +val blocks' = (fst o dest_list o dest_BirProgram o eval o lhs o concl) cprog'_def val endings' = List.map (fn block_tm => eval “ ^block_tm.bb_last_statement”) blocks' (*Obtain WP contract*) @@ -77,6 +77,6 @@ val post_tm = “\l. if (l = BL_Address (Imm64 0x400084w)) else bir_exp_false” val defs = [cprog'_def, post_def, bir_exp_false_def, bir_exp_true_def] -val ccontract = prove_and_transfer_contract(“bir_composition_prog”, cprog'_tm, cprog'_thm, +val ccontract = prove_and_transfer_contract(cprog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) diff --git a/examples/ijr/evaluation.sml b/examples/ijr/evaluation.sml index adb29a035..e7d28205c 100644 --- a/examples/ijr/evaluation.sml +++ b/examples/ijr/evaluation.sml @@ -11,7 +11,7 @@ fun test_resolve_indirect_jumps(middle_blocks_n) = val prog_tm = (lhs o concl) prog_def val args = gen_args_program(middle_blocks_n, 1) val start = timer_start() - val (prog'_tm, prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) + val (prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) val stop = timer_stop start in (middle_blocks_n, stop) @@ -24,7 +24,7 @@ fun test_partial_resolve_indirect_jumps(middle_blocks_n) = val prog_tm = (lhs o concl) prog_def val args = gen_partial_args_program(middle_blocks_n, 100) val start = timer_start() - val (prog'_tm, prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) + val (prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) val stop = timer_stop start in (middle_blocks_n, stop) @@ -48,7 +48,7 @@ fun test_transfer_contract (middle_blocks_n) = cheat) val start = timer_start() - val ht'_thm = transfer_contract(prog_tm, prog'_thm, ht_thm') + val ht'_thm = transfer_contract(prog'_thm, ht_thm') val stop = timer_stop start in (middle_blocks_n, stop) diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml index bfef170d7..2790115f4 100644 --- a/examples/ijr/examplesScript.sml +++ b/examples/ijr/examplesScript.sml @@ -61,7 +61,7 @@ val prog2'_tm = (dest_some o rhs o concl) prog2'_thm (*resolve_indirect_jumps and transfer_contract test*) (*Transform program*) val small_args = “[(BL_Address (Imm64 0w), [(Imm64 4w, "0w-2")], ^arg3)]” -val (small_prog'_tm, small_prog'_def, small_prog'_thm) = +val (small_prog'_def, small_prog'_thm) = resolve_indirect_jumps("resolved_small_prog", prog_tm, small_args) (*Obtain WP contract*) @@ -76,7 +76,7 @@ val post_tm = “\l. if (l = BL_Address (Imm64 4w)) else bir_exp_false” val defs = [small_prog'_def, post_def, bir_exp_false_def] -val small_contract = prove_and_transfer_contract(prog_tm, small_prog'_tm, small_prog'_thm, +val small_contract = prove_and_transfer_contract(small_prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) @@ -88,7 +88,7 @@ val large_prog_def = gen_program("prog", middle_blocks_n) val large_prog_tm = (lhs o concl) large_prog_def val large_prog_args = gen_args_program(middle_blocks_n, 1) -val (large_prog'_tm, large_prog'_def, large_prog'_thm) = +val (large_prog'_def, large_prog'_thm) = resolve_indirect_jumps("resolved_large_prog", large_prog_tm, large_prog_args) val pre_def = Define ‘pre = ^(blt((bden o bvarimm64) "x", (bconst64 middle_blocks_n)))’ @@ -102,7 +102,7 @@ val post_tm = “\l. if (l = ^(blabel_addr64 exit_addr)) else bir_exp_false” val defs = [large_prog'_def, post_def, bir_exp_false_def, bir_exp_true_def] -val large_contract = prove_and_transfer_contract(large_prog_tm, large_prog'_tm, large_prog'_thm, +val large_contract = prove_and_transfer_contract(large_prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) diff --git a/examples/ijr/resolveFullyLib.sml b/examples/ijr/resolveFullyLib.sml index 2cf9f7fb1..5aba23db7 100644 --- a/examples/ijr/resolveFullyLib.sml +++ b/examples/ijr/resolveFullyLib.sml @@ -20,11 +20,12 @@ fun resolve_indirect_jumps(prog'_name, prog_tm, args) = val prog'_tm' = (lhs o concl) prog'_def val prog'_thm' = REWRITE_RULE [GSYM prog'_def] prog'_thm in - (prog'_tm', prog'_def, prog'_thm') + (prog'_def, prog'_thm') end -fun transfer_contract(prog_tm, prog'_thm, ht_thm) = +fun transfer_contract(prog'_thm, ht_thm) = let + val prog_tm = (el 1 o snd o strip_comb o lhs o concl) prog'_thm val ht_tm = concl ht_thm val (_, entry_tm, exits_tm, _, _) = dest_bir_exec_to_labels_triple ht_tm val entry_thm = prove ( @@ -40,9 +41,10 @@ fun transfer_contract(prog_tm, prog'_thm, ht_thm) = MATCH_MP res_thm ht_thm end -fun prove_and_transfer_contract(prog_tm, prog'_tm, prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) = +fun prove_and_transfer_contract(prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) = let val wp_start = timer_start () + val prog'_tm = (dest_some o rhs o concl) prog'_thm (*Obtain WP contract*) val (ht_thm, wp_tm) = bir_obtain_ht @@ -58,7 +60,7 @@ fun prove_and_transfer_contract(prog_tm, prog'_tm, prog'_thm, prefix, pre_tm, en (*Transfer WP contract*) val transfer_start = timer_start () - val ht'_thm = transfer_contract(prog_tm, prog'_thm, ht_thm') + val ht'_thm = transfer_contract(prog'_thm, ht_thm') val _ = print ("Transfer time: " ^ timer_stop_str transfer_start ^ "\n") (*Prove implication using SMT solvers*) From 1cd49fe4514b52787e563bb722521d2c55bf4c62 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Fri, 11 Jun 2021 15:56:33 +0200 Subject: [PATCH 0057/1015] Add proof of the two unproven lemmas and contract transfer theorem for bir_simp_jgmt (#11) * Add proof of second unproven lemma and contract transfer theorem for bir_simp_jgmt * Add Didriks proof of first unproven lemma and simplify it --- examples/ijr/Makefile | 1 + examples/ijr/contractTransferScript.sml | 257 ++++++++++++++++++++++-- 2 files changed, 241 insertions(+), 17 deletions(-) diff --git a/examples/ijr/Makefile b/examples/ijr/Makefile index e3c5af1df..15aadbcb5 100644 --- a/examples/ijr/Makefile +++ b/examples/ijr/Makefile @@ -9,6 +9,7 @@ all: build evalc evalbir build: # Count lines for proof-producing procedures and verified function + Holmake wc -l resolveFullyLib.sml wc -l resolveFullyScript.sml resolveScript.sml resolutionScript.sml simulationScript.sml simulationFailScript.sml contractTransferScript.sml wc -l cProgEvaluation.sml diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index d704079a0..4ca43fcc8 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -1,9 +1,13 @@ -open HolKernel Parse boolLib bossLib; +open HolKernel Parse boolLib bossLib BasicProvers; open listTheory pred_setTheory pred_setSimps; open bir_programTheory bir_htTheory bir_program_multistep_propsTheory; open HolBACoreSimps; +open bir_wm_instTheory bir_auxiliaryTheory; +open abstract_simp_hoare_logicTheory abstract_hoare_logicTheory; +open abstract_hoare_logicSimps bir_program_env_orderTheory bir_env_oldTheory; +open bir_auxiliaryLib; open resolutionTheory simulationTheory simulationFailTheory; @@ -116,6 +120,7 @@ QED Theorem bir_exec_to_labels_expand_labels: ∀ls ls' p s s' os c1 c2. + ~bir_state_is_terminated s' ⇒ ls SUBSET ls' ⇒ bir_exec_to_labels ls p s = BER_Ended os c1 c2 s' ⇒ (∃n c2'. @@ -126,22 +131,184 @@ Theorem bir_exec_to_labels_expand_labels: bir_exec_to_labels_n ls' p s n' = BER_Ended os' c1' c2'' s'' ∧ ~(s''.bst_pc.bpc_label IN ls))) Proof -cheat +REPEAT STRIP_TAC >> +FULL_SIMP_TAC std_ss [bir_exec_to_labels_def] >> +IMP_RES_TAC bir_exec_to_labels_n_change_labels >> +rename1 ‘bir_exec_to_labels_n _ _ _ n = BER_Ended _ _ c2' s''’ >> +Q.LIST_EXISTS_TAC [‘n’, ‘c2'’] >> +FULL_SIMP_TAC arith_ss [] >> +REPEAT STRIP_TAC >> + +(* 1. Prove that the Ended result of the conclusion exists. *) +subgoal ‘∃s' os1 c11 c21'. + bir_exec_to_labels_n ls' p s n' = BER_Ended os1 c11 c21' s'’ >- ( + FULL_SIMP_TAC std_ss [bir_exec_to_labels_n_def] >> + PROVE_TAC [bir_exec_steps_GEN_decrease_max_steps_Ended_SOME] +) >> +ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> + +(* 2. Prove that the state reached by n'-to-label steps to ls' is not in ls *) +FULL_SIMP_TAC std_ss [bir_exec_to_labels_n_def] >> +‘c11 < c1’ by METIS_TAC [bir_exec_steps_GEN_decrease_max_steps_Ended_steps_taken] >> +‘~bir_state_is_terminated s'’ by PROVE_TAC [bir_exec_steps_GEN_SOME_EQ_Ended] >> +Q.PAT_X_ASSUM ‘bir_exec_steps_gen _ _ _ (SOME n) = _’ (K ALL_TAC) >> + +Q.SUBGOAL_THEN ‘~bir_state_COUNT_PC (F,(\pc. pc.bpc_index = 0 ∧ pc.bpc_label IN ls)) + (bir_exec_infinite_steps_fun p s c11)’ + MP_TAC >- ( + subgoal ‘0 < c11’ >- ( + IMP_RES_TAC bir_exec_steps_GEN_SOME_EQ_Ended_Running_steps >> + ASM_SIMP_TAC arith_ss [] + ) >> + METIS_TAC [bir_exec_steps_GEN_1_EQ_Ended] +) >> +Q.PAT_X_ASSUM ‘_ = BER_Ended os c1 c2 s''’ (K ALL_TAC) >> + +FULL_SIMP_TAC std_ss [bir_exec_steps_GEN_SOME_EQ_Ended, bir_state_is_terminated_def] >> +REPEAT (Q.PAT_X_ASSUM ‘∀n. _’ (K ALL_TAC)) >> +Q.PAT_X_ASSUM ‘c21' = _’ (ASSUME_TAC o GSYM) >> +Q.PAT_X_ASSUM ‘s' = _’ (ASSUME_TAC o GSYM) >> +ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_state_COUNT_PC_def] >> +DISCH_THEN MATCH_MP_TAC >> +‘c21' = n'’ by ASM_SIMP_TAC arith_ss [] >> +FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_state_COUNT_PC_def] QED +(*bir_exec_to_labels_restrict_labels and bir_exec_to_labels_n_restrict_labels can + probably be proved more succinctly using the same strategy as in bir_exec_to_labels_expand_labels*) + Theorem bir_exec_to_labels_restrict_labels: + ∀ls ls' p s s' os c1 c2. + ls SUBSET ls' ⇒ + bir_exec_to_labels ls' p s = BER_Ended os c1 c2 s' ⇒ + s'.bst_pc.bpc_label IN ls ⇒ + ~bir_state_is_terminated s' ⇒ + (∃os' c1' c2'. bir_exec_to_labels ls p s = BER_Ended os' c1' c2' s') +Proof +REPEAT STRIP_TAC >> +subgoal ‘bir_weak_trs ls' p s = SOME s'’ >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_weak_trs_def] +) >> +Q.SUBGOAL_THEN ‘bir_weak_trs ls p s = SOME s'’ MP_TAC >- ( + ‘weak_model (bir_etl_wm p)’ by PROVE_TAC [bir_model_is_weak] >> + FULL_SIMP_TAC (std_ss++bir_wm_SS) [weak_model_def, bir_etl_wm_def] >> + POP_ASSUM (K ALL_TAC) >> + + Q.EXISTS_TAC ‘n’ >> + RW_TAC std_ss [] >> + PROVE_TAC [SUBSET_DEF] +) >> +SIMP_TAC (std_ss++holBACore_ss) [bir_weak_trs_def, bir_etl_wm_def] >> +REPEAT CASE_TAC +QED + +Theorem bir_exec_to_labels_n_restrict_labels: ∀ls ls' n p s s' os c1 c2. ls SUBSET ls' ⇒ n > 0 ⇒ bir_exec_to_labels_n ls' p s n = BER_Ended os c1 c2 s' ⇒ s'.bst_pc.bpc_label IN ls ⇒ + ~bir_state_is_terminated s' ⇒ (∀n'. 0 < n' ∧ n' < n ⇒ ∃s'' os' c1' c2''. bir_exec_to_labels_n ls' p s n' = BER_Ended os' c1' c2'' s'' ∧ ~(s''.bst_pc.bpc_label IN ls)) ⇒ - (∃c2'. bir_exec_to_labels ls p s = BER_Ended os c1 c2' s') + (∃os' c1' c2'. bir_exec_to_labels ls p s = BER_Ended os' c1' c2' s') Proof -cheat +Induct_on ‘n’ >> +REPEAT GEN_TAC >> +SIMP_TAC arith_ss [bir_exec_to_labels_n_REWR_SUC] >> +REPEAT CASE_TAC >> +REPEAT STRIP_TAC >> +Q.PAT_X_ASSUM ‘b' = s'’ SUBST_ALL_TAC >> +rename1 ‘bir_exec_to_labels_n _ _ _ _ = BER_Ended os2 c12 c22 s''’ >> +rename1 ‘bir_exec_to_labels _ _ _ = BER_Ended os1 c11 c21 s'’ >> + +(*Execution one step*) +Cases_on ‘n = 0’ >- ( + FULL_SIMP_TAC (arith_ss++holBACore_ss) [bir_exec_to_labels_n_REWR_0] >> + PROVE_TAC [bir_exec_to_labels_restrict_labels] +) >> + +(*Execution multiple steps*) +(*Use induction hypothesis*) +Q.PAT_X_ASSUM ‘∀ls. ∀ls'. _’ (MP_TAC o Q.SPECL [‘ls’, ‘ls'’, ‘p’, ‘s'’]) >> +ASM_SIMP_TAC (arith_ss++holBACore_ss) [] >> +Q.SUBGOAL_THEN ‘∀n'. + 0 < n' ∧ n' < n ⇒ + ∃s'' os' c1' c2''. + bir_exec_to_labels_n ls' p s' n' = BER_Ended os' c1' c2'' s'' ∧ + s''.bst_pc.bpc_label ∉ ls’ + (fn thm => RW_TAC std_ss [thm])>- ( + REPEAT STRIP_TAC >> + Q.PAT_X_ASSUM ‘∀n'. _’ (MP_TAC o Q.SPEC ‘SUC n'’) >> + ASM_SIMP_TAC (arith_ss++holBACore_ss) [bir_exec_to_labels_n_REWR_SUC] >> + CASE_TAC +) >> +Q.PAT_X_ASSUM ‘bir_exec_to_labels_n ls' _ s' _ = _’ (K ALL_TAC) >> + +(*Use weakness assumption*) +subgoal ‘s'.bst_pc.bpc_label NOTIN ls’ >- ( + Q.PAT_X_ASSUM ‘∀n'. _’ (MP_TAC o Q.SPEC ‘1’) >> + ASM_SIMP_TAC (arith_ss++holBACore_ss) [GSYM bir_exec_to_labels_def] +) >> + +(*Convert transitions*) +subgoal ‘bir_weak_trs ls' p s = SOME s'’ >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_weak_trs_def] >> + CCONTR_TAC >> + FULL_SIMP_TAC (std_ss++holBACore_ss) [bir_exec_to_labels_def, + bir_exec_to_labels_n_REWR_TERMINATED] >> + PROVE_TAC [] +) >> +Q.PAT_X_ASSUM ‘bir_exec_to_labels ls' _ s = _’ (K ALL_TAC) >> +subgoal ‘bir_weak_trs ls p s' = SOME s''’ >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_weak_trs_def] +) >> +Q.PAT_X_ASSUM ‘bir_exec_to_labels ls _ s' = _’ (K ALL_TAC) >> + +(*Use weak model property*) +Q.SUBGOAL_THEN ‘bir_weak_trs ls p s = SOME s''’ MP_TAC >- ( + ‘weak_model (bir_etl_wm p)’ by PROVE_TAC [bir_model_is_weak] >> + FULL_SIMP_TAC (std_ss++bir_wm_SS) [weak_model_def, bir_etl_wm_def] >> + POP_ASSUM (K ALL_TAC) >> + rename1 ‘FUNPOW_OPT _ n2 s = _’ >> + rename1 ‘FUNPOW_OPT _ n3 s' = _’ >> + + (*Show existance*) + Q.EXISTS_TAC ‘n3 + n2’ >> + CONJ_TAC >- ( + ‘n3 + n2 > 0’ by ASM_SIMP_TAC arith_ss [] >> + PROVE_TAC [FUNPOW_OPT_ADD_thm] + ) >> + REPEAT STRIP_TAC >> + rename1 ‘n1 < _ + _’ >> + + Cases_on ‘n1 < n2’ >- ( + PROVE_TAC [SUBSET_DEF] + ) >> + + (*n1 >= n2*) + subgoal ‘∃m. n1 = n2 + m’ >- ( + ‘n2 ≤ n1’ by ASM_SIMP_TAC arith_ss [] >> + PROVE_TAC [arithmeticTheory.LESS_EQUAL_ADD] + ) >> + ASM_SIMP_TAC std_ss [] >> + Q.PAT_X_ASSUM ‘∀n'. _’ (MP_TAC o Q.SPEC ‘m’) >> + ASM_SIMP_TAC arith_ss [] >> + + (*n1 = n2*) + Cases_on ‘m = 0’ >- ( + ASM_SIMP_TAC std_ss [] + ) >> + + (*n1 > n2*) + ASM_SIMP_TAC arith_ss [] >> + PROVE_TAC [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] +) >> + +ASM_SIMP_TAC (std_ss++holBACore_ss) [bir_weak_trs_def, bir_etl_wm_def] >> +REPEAT CASE_TAC QED Theorem simulated_termination_transitive: @@ -174,14 +341,15 @@ subgoal ‘∃os1 m1 n1. bir_exec_to_labels_n pls2 p2 s n = ) >> (*Restrict label set*) -subgoal ‘∃n1'.bir_exec_to_labels pls1 p2 s = BER_Ended os1 m1 n1' s'’ >- ( - IRULE_TAC bir_exec_to_labels_restrict_labels >> +subgoal ‘∃os1' m1' n1'.bir_exec_to_labels pls1 p2 s = BER_Ended os1' m1' n1' s'’ >- ( + IRULE_TAC bir_exec_to_labels_n_restrict_labels >> + ASM_SIMP_TAC std_ss [] >> CONJ_TAC >- ( ‘(1:num) > 0’ by SIMP_TAC arith_ss [] >> METIS_TAC [bir_exec_to_labels_def, bir_exec_to_labels_n_ended_running] ) >> - Q.LIST_EXISTS_TAC [‘n1’, ‘pls2’, ‘n’] >> CONJ_TAC >- ( + Q.LIST_EXISTS_TAC [‘m1’, ‘n1’, ‘pls2’, ‘n’, ‘os1’] >> CONJ_TAC >- ( REPEAT STRIP_TAC >> Q.PAT_X_ASSUM ‘∀n'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘n'’ thm)) >> REV_FULL_SIMP_TAC std_ss [] >> @@ -244,14 +412,15 @@ subgoal ‘∃os1 m1 n1. bir_exec_to_labels_n (set pls) p s n = ) >> (*Restrict label set*) -subgoal ‘∃n1'.bir_exec_to_labels ls p s = BER_Ended os1 m1 n1' s'’ >- ( - IRULE_TAC bir_exec_to_labels_restrict_labels >> +subgoal ‘∃os1' m1' n1'. bir_exec_to_labels ls p s = BER_Ended os1' m1' n1' s'’ >- ( + IRULE_TAC bir_exec_to_labels_n_restrict_labels >> + ASM_SIMP_TAC std_ss [] >> CONJ_TAC >- ( ‘(1:num) > 0’ by SIMP_TAC arith_ss [] >> METIS_TAC [bir_exec_to_labels_def, bir_exec_to_labels_n_ended_running] ) >> - Q.LIST_EXISTS_TAC [‘n1’, ‘set pls’, ‘n’] >> CONJ_TAC >- ( + Q.LIST_EXISTS_TAC [‘m1’, ‘n1’, ‘set pls’, ‘n’, ‘os1’] >> CONJ_TAC >- ( REPEAT STRIP_TAC >> Q.PAT_X_ASSUM ‘∀n'. _’ (fn thm => ASSUME_TAC (Q.SPEC ‘n'’ thm)) >> REV_FULL_SIMP_TAC std_ss [] >> @@ -288,15 +457,13 @@ Theorem contract_transfer: Proof SIMP_TAC std_ss [bir_exec_to_labels_triple_def] >> REPEAT STRIP_TAC >> -Q.PAT_X_ASSUM ‘simulated_termination p p'’ - (ASSUME_TAC o MATCH_MP simulated_termination_simulated_contract) >> Q.PAT_X_ASSUM ‘∀s'. _’ (MP_TAC o Q.SPEC ‘s’) >> subgoal ‘bir_env_vars_are_initialised s.bst_environ (bir_vars_of_program p')’ >- ( - IRULE_TAC bir_env_oldTheory.bir_env_vars_are_initialised_SUBSET >> - PROVE_TAC [] + PROVE_TAC [bir_env_vars_are_initialised_SUBSET] ) >> -ASM_SIMP_TAC std_ss [] >> STRIP_TAC >> +ASM_SIMP_TAC std_ss [] >> +STRIP_TAC >> rename1 ‘_ = BER_Ended o2 m2 n2 s'’ >> subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = @@ -307,10 +474,66 @@ subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = bir_programcounter_t_component_equality] ) >> ‘~(bir_state_is_terminated s')’ by ASM_SIMP_TAC (std_ss++holBACore_ss) [] >> - METIS_TAC [simulated_contract_def] + METIS_TAC [simulated_termination_simulated_contract, simulated_contract_def] ) >> -PROVE_TAC [] +ASM_SIMP_TAC (std_ss++holBACore_ss) [] +QED + +Theorem bir_simp_jgmt_transfer: + ∀ p p' i l ls ls' pre post. + simulated_termination p p' ⇒ + (bir_vars_of_program p') SUBSET (bir_vars_of_program p) ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + ls' SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_simp_jgmt p' i l ls ls' pre post ⇒ + bir_simp_jgmt p i l ls ls' pre post +Proof +SIMP_TAC (std_ss++bir_wm_SS) + [bir_simp_jgmt_def, abstract_simp_jgmt_def, + abstract_jgmt_def, bir_etl_wm_def, bir_weak_trs_def] >> +REPEAT STRIP_TAC >> + +Q.PAT_X_ASSUM ‘∀s'. _’ (MP_TAC o Q.SPEC ‘s’) >> +Q.SUBGOAL_THEN ‘bir_exec_to_labels_triple_precond s pre p'’ + (fn thm => ASM_SIMP_TAC std_ss [thm]) >- ( + FULL_SIMP_TAC std_ss [bir_exec_to_labels_triple_precond_def] >> + PROVE_TAC [bir_env_vars_are_initialised_SUBSET] +) >> +Q.SUBGOAL_THEN ‘bir_exec_to_labels_triple_precond s i p'’ + (fn thm => SIMP_TAC std_ss [thm]) >- ( + FULL_SIMP_TAC std_ss [bir_exec_to_labels_triple_precond_def] >> + PROVE_TAC [bir_env_vars_are_initialised_SUBSET] +) >> +NTAC 2 CASE_TAC >> +REPEAT STRIP_TAC >> +rename1 ‘_ = BER_Ended o2 m2 n2 s'’ >> + +subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels (ls ∪ ls') p s = + BER_Ended o1 m1 n1 s'’ >- ( + subgoal ‘s.bst_pc = bir_block_pc l’ >- ( + ASM_SIMP_TAC (std_ss++holBACore_ss) + [bir_block_pc_def, + bir_programcounter_t_component_equality] >> + FULL_SIMP_TAC std_ss [bir_exec_to_labels_triple_precond_def] + ) >> + ‘ls ∪ ls' ⊆ set (bir_labels_of_program p)’ by PROVE_TAC [UNION_SUBSET] >> + METIS_TAC [simulated_contract_def, simulated_termination_simulated_contract] +) >> +ASM_SIMP_TAC (std_ss++bir_TYPES_ss) [] >> + +STRIP_TAC >- ( + FULL_SIMP_TAC std_ss [bir_exec_to_labels_triple_precond_def, + bir_exec_to_labels_triple_postcond_def] >> + PROVE_TAC [bir_env_vars_are_initialised_ORDER, + bir_exec_to_labels_def, bir_exec_to_labels_n_ENV_ORDER] +) >> +FULL_SIMP_TAC std_ss [bir_exec_to_labels_triple_precond_def] >> +PROVE_TAC [bir_env_vars_are_initialised_ORDER, + bir_exec_to_labels_def, bir_exec_to_labels_n_ENV_ORDER] QED From d67bce2179d9aa895e6d631993198831d33082df Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Tue, 22 Jun 2021 14:01:34 +0200 Subject: [PATCH 0058/1015] Fixed bug in procedure bir_populate_blacklist' causing it to throw an exception --- src/tools/comp/bir_compositionLib.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tools/comp/bir_compositionLib.sml b/src/tools/comp/bir_compositionLib.sml index 6a50331a9..77718941a 100644 --- a/src/tools/comp/bir_compositionLib.sml +++ b/src/tools/comp/bir_compositionLib.sml @@ -292,7 +292,7 @@ open bir_inst_liftingHelpersLib; HO_MATCH_MP new_map_triple3 (SIMP_RULE std_ss [] elabel_post_is_false_thm) (* Finalize with assumption and INSERT and DELETE simplification *) val new_map_triple5 = - SIMP_RULE std_ss [ASSUME assmpt] + SIMP_RULE (std_ss++stringSimps.STRING_ss++string_ss) [ASSUME assmpt] (simp_delete_set_repr_rule new_map_triple4) val new_map_triple6 = simp_insert_set_repr_rule new_map_triple5 From 6798c443a6ffc25016962bf9cd2743dd4c5a6e33 Mon Sep 17 00:00:00 2001 From: Adrian Westerberg Date: Thu, 24 Jun 2021 11:25:30 +0200 Subject: [PATCH 0059/1015] Improve ijr transformation and synthetic BIR program evaluation (#12) * Change ijr program transformation to use halt and adapt proofs and evaluations *Add HolBA bugfix * Optimise ijr program transformation slightly *Add new experiment to synthetic BIR program evaluation *Improve other experiments in synthetic BIR program evaluation --- examples/ijr/cProgEvaluation.sml | 10 +- examples/ijr/evaluation.sml | 26 +++++- examples/ijr/examplesScript.sml | 19 ++-- examples/ijr/generationLib.sml | 10 +- examples/ijr/plot.py | 24 +++-- examples/ijr/resolutionScript.sml | 25 ++--- examples/ijr/resolveFullyLib.sml | 52 +++++++++-- examples/ijr/resolveFullyScript.sml | 127 ++++++++++++++------------ examples/ijr/resolveScript.sml | 51 ++++++----- examples/ijr/simulationFailScript.sml | 12 +-- src/tools/comp/bir_compositionLib.sml | 2 +- 11 files changed, 220 insertions(+), 138 deletions(-) diff --git a/examples/ijr/cProgEvaluation.sml b/examples/ijr/cProgEvaluation.sml index 5ee799938..e44115b28 100644 --- a/examples/ijr/cProgEvaluation.sml +++ b/examples/ijr/cProgEvaluation.sml @@ -44,11 +44,11 @@ val call_comp_next_adress = (#1 o dest_bir_block o el 34) blocks (*Transform program*) -val add_two_ret_args = [(add_two_ret_address, [0x400050], ["0x400014w-1"], 0x400084)] -val add_one_ret_args = [(add_one_ret_address, [0x400058], ["0x40002Cw-1"], 0x400084)] -val call_add_two_args = [(call_add_two_address, [0x400000], ["0x40004Cw-1"], 0x400084)] -val call_add_one_args = [(call_add_one_address, [0x400018], ["0x400054w-1"], 0x400084)] -val comp_ret_args = [(comp_ret_address, [0x400084], ["0x40005Cw-1"], 0x400084)] +val add_two_ret_args = [(add_two_ret_address, [0x400050], ["0x400014w-1"])] +val add_one_ret_args = [(add_one_ret_address, [0x400058], ["0x40002Cw-1"])] +val call_add_two_args = [(call_add_two_address, [0x400000], ["0x40004Cw-1"])] +val call_add_one_args = [(call_add_one_address, [0x400018], ["0x400054w-1"])] +val comp_ret_args = [(comp_ret_address, [0x400084], ["0x40005Cw-1"])] val composition_args = gen_args (add_two_ret_args @ add_one_ret_args @ diff --git a/examples/ijr/evaluation.sml b/examples/ijr/evaluation.sml index e7d28205c..de66054fa 100644 --- a/examples/ijr/evaluation.sml +++ b/examples/ijr/evaluation.sml @@ -18,6 +18,19 @@ fun test_resolve_indirect_jumps(middle_blocks_n) = end fun test_partial_resolve_indirect_jumps(middle_blocks_n) = + let + val exit_addr = 10 * middle_blocks_n + val prog_def = gen_program("prog", middle_blocks_n) + val prog_tm = (lhs o concl) prog_def + val args = gen_partial_args_program(middle_blocks_n, middle_blocks_n div 20) + val start = timer_start() + val (prog'_def, prog'_thm) = resolve_indirect_jumps("resolved_gen_prog", prog_tm, args) + val stop = timer_stop start + in + (middle_blocks_n, stop) + end + +fun test_constant_resolve_indirect_jumps(middle_blocks_n) = let val exit_addr = 10 * middle_blocks_n val prog_def = gen_program("prog", middle_blocks_n) @@ -44,7 +57,7 @@ fun test_transfer_contract (middle_blocks_n) = then bir_exp_true else bir_exp_false” val ht_thm' = prove( - “bir_exec_to_labels_triple prog' ^entry_label_tm ^ending_labels_tm bir_exp_true ^post_tm”, + “bir_simp_jgmt prog' bir_exp_true ^entry_label_tm ^ending_labels_tm {} bir_exp_true ^post_tm”, cheat) val start = timer_start() @@ -80,22 +93,27 @@ fun linspace(start, n, stop) = range(start, (stop - start) div n, stop) (*200 64s*) -val resolve_middle_blocks_ns = range(10, 10, 200) +val resolve_middle_blocks_ns = range(10, 20, 210) val resolve_results = List.map (test_resolve_indirect_jumps) resolve_middle_blocks_ns val _ = List.map print_test_result resolve_results val _ = write_test_results("resolve", resolve_results) (*val _ = Posix.Process.sleep (Time.fromSeconds (Int.toLarge 60))*) -val partial_resolve_middle_blocks_ns = range(100, 100, 2000) +val partial_resolve_middle_blocks_ns = range(100, 200, 2100) val partial_resolve_results = List.map (test_partial_resolve_indirect_jumps) partial_resolve_middle_blocks_ns val _ = List.map print_test_result partial_resolve_results val _ = write_test_results("partial_resolve", partial_resolve_results) +val constant_resolve_middle_blocks_ns = range(100, 200, 2100) +val constant_resolve_results = List.map (test_constant_resolve_indirect_jumps) constant_resolve_middle_blocks_ns +val _ = List.map print_test_result constant_resolve_results +val _ = write_test_results("constant_resolve", constant_resolve_results) + (*val _ = Posix.Process.sleep (Time.fromSeconds (Int.toLarge 60))*) (*80000 53s*) -val transfer_middle_blocks_ns = range(1000, 2000, 38000) +val transfer_middle_blocks_ns = range(1000, 4000, 38000) val transfer_results = List.map test_transfer_contract transfer_middle_blocks_ns val _ = List.map print_test_result transfer_results val _ = write_test_results("transfer", transfer_results) diff --git a/examples/ijr/examplesScript.sml b/examples/ijr/examplesScript.sml index 2790115f4..626279371 100644 --- a/examples/ijr/examplesScript.sml +++ b/examples/ijr/examplesScript.sml @@ -24,7 +24,7 @@ val prog_def = bdefprog_list "prog" [block1, block2] val prog_tm = (lhs o concl) prog_def (*resolve_fail and resolve tests*) -val resolve_fail_prog'_thm = EVAL “resolve_fail ^prog_tm (BL_Address (Imm64 0w)) (Imm64 4w)” +val resolve_fail_prog'_thm = EVAL “resolve_fail ^prog_tm (BL_Address (Imm64 0w))” val resolve_fail_prog'_tm = (dest_some o rhs o concl) resolve_fail_prog'_thm val resolve_prog'_thm = EVAL “resolve ^prog_tm (BL_Address (Imm64 0w)) (Imm64 10w) "0w-1"” @@ -34,13 +34,12 @@ val resolve_prog'_tm = (dest_some o rhs o concl) resolve_prog'_thm (*resolve_fully test*) val arg1 = “BL_Address (Imm64 0w)” val arg2 = “[(Imm64 10w, "0w-1"); (Imm64 4w, "0w-2")]” -val arg3 = “Imm64 4w” -val resolve_fully_prog'_thm = EVAL “resolve_fully ^prog_tm ^arg1 ^arg2 ^arg3” +val resolve_fully_prog'_thm = EVAL “resolve_fully ^prog_tm ^arg1 ^arg2” val resolve_fully_prog'_tm = (dest_some o rhs o concl) resolve_fully_prog'_thm (*resolve_fully_n one indirect jump test many steps*) -val resolve_fully_n_args = “[(^arg1, ^arg2, ^arg3)]” +val resolve_fully_n_args = “[(^arg1, ^arg2)]” val resolve_fully_n_prog'_thm = EVAL “resolve_fully_n ^prog_tm ^resolve_fully_n_args” val resolve_fully_n_prog'_tm = (dest_some o rhs o concl) resolve_fully_n_prog'_thm @@ -52,24 +51,25 @@ val block1' = (blabel_addr64 8, val prog2_def = bdefprog_list "prog2" [block1, block2, block1'] val prog2_tm = (rhs o concl) prog2_def -val prog2_args = “[(^arg1, ^arg2, ^arg3); - (BL_Address (Imm64 8w), [(Imm64 10w, "8w-1"); (Imm64 4w, "8w-2")], ^arg3)]” +val prog2_args = “[(^arg1, ^arg2); + (BL_Address (Imm64 8w), [(Imm64 10w, "8w-1"); (Imm64 4w, "8w-2")])]” val prog2'_thm = EVAL “resolve_fully_n ^prog2_tm ^prog2_args” val prog2'_tm = (dest_some o rhs o concl) prog2'_thm (*resolve_indirect_jumps and transfer_contract test*) (*Transform program*) -val small_args = “[(BL_Address (Imm64 0w), [(Imm64 4w, "0w-2")], ^arg3)]” +val small_args = “[(BL_Address (Imm64 0w), [(Imm64 4w, "0w-2")])]” val (small_prog'_def, small_prog'_thm) = resolve_indirect_jumps("resolved_small_prog", prog_tm, small_args) (*Obtain WP contract*) val pre_def = Define ‘pre = bir_exp_true’ val post_def = Define ‘post = ^(beq((bden o bvarimm64) "y", bconst64 4))’ -val prefix = "example1_" +val prefix = "example1" val pre_tm = (lhs o concl) pre_def val entry_label_tm = “BL_Address (Imm64 0w)” + val ending_labels_tm = “{BL_Address (Imm64 4w)}” val post_tm = “\l. if (l = BL_Address (Imm64 4w)) then post @@ -91,9 +91,10 @@ val large_prog_args = gen_args_program(middle_blocks_n, 1) val (large_prog'_def, large_prog'_thm) = resolve_indirect_jumps("resolved_large_prog", large_prog_tm, large_prog_args) + val pre_def = Define ‘pre = ^(blt((bden o bvarimm64) "x", (bconst64 middle_blocks_n)))’ val post_def = Define ‘post = ^(beq((bden o bvarimm64) "y", bconst64 exit_addr))’ -val prefix = "example2_" +val prefix = "example2" val pre_tm = (lhs o concl) pre_def val entry_label_tm = “BL_Label "entry1"” val ending_labels_tm = “{^(blabel_addr64 exit_addr)}” diff --git a/examples/ijr/generationLib.sml b/examples/ijr/generationLib.sml index 8d4f690ed..e8fe055ee 100644 --- a/examples/ijr/generationLib.sml +++ b/examples/ijr/generationLib.sml @@ -57,12 +57,12 @@ fun gen_arg2(ns, ss) = mk_list(list, “:(bir_imm_t#string)”) end -fun gen_arg(label, ns, ss, exit_addr) = - mk_pair(label, mk_pair(gen_arg2(ns, ss), mk_Imm_of_int 64 exit_addr)) +fun gen_arg(label, ns, ss) = + mk_pair(label, gen_arg2(ns, ss)) fun gen_args(xs) = let - val ty = “:(bir_label_t # ((bir_imm_t#string) list) # bir_imm_t)” + val ty = “:(bir_label_t # (bir_imm_t#string) list)” in mk_list(List.map gen_arg xs, ty) end @@ -72,7 +72,7 @@ fun gen_args_entry_block2(middle_blocks_n) = val targets = List.tabulate(middle_blocks_n, fn i => i); val fresh_labels = gen_label_strings("entry2", middle_blocks_n); in - [(blabel_str "entry2", targets, fresh_labels, middle_blocks_n - 1)] + [(blabel_str "entry2", targets, fresh_labels)] end fun gen_args_middle_block(addr, exit_addr, m) = @@ -80,7 +80,7 @@ fun gen_args_middle_block(addr, exit_addr, m) = val targets = List.tabulate(m, fn _ => exit_addr); val fresh_labels = gen_label_strings(Int.toString(addr)^"w", m); in - [(blabel_addr64 addr, targets, fresh_labels, exit_addr)] + [(blabel_addr64 addr, targets, fresh_labels)] end fun gen_args_middle_blocks(addrs, exit_addr, m) = diff --git a/examples/ijr/plot.py b/examples/ijr/plot.py index 9f99c8a28..2805b32fb 100755 --- a/examples/ijr/plot.py +++ b/examples/ijr/plot.py @@ -4,10 +4,10 @@ resolve = np.genfromtxt('resolve', delimiter=',', names=['size', 'time']) -plt.plot(resolve['size'], resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic programs') +plt.plot(resolve['size'], resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic BIR programs') plt.xlabel('Program size (middle blocks)') plt.ylabel('Time (seconds)') -plt.title('resolve_indirect_jumps benchmark') +plt.title('Experiment 1') plt.legend() plt.savefig('resolve.png') @@ -16,22 +16,34 @@ partial_resolve = np.genfromtxt('partial_resolve', delimiter=',', names=['size', 'time']) -plt.plot(partial_resolve['size'], partial_resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic programs') +plt.plot(partial_resolve['size'], partial_resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic BIR programs') plt.xlabel('Program size (middle blocks)') plt.ylabel('Time (seconds)') -plt.title('resolve_indirect_jumps benchmark') +plt.title('Experiment 2') plt.legend() plt.savefig('partial_resolve.png') plt.figure() +constant_resolve = np.genfromtxt('constant_resolve', delimiter=',', names=['size', 'time']) + +plt.plot(constant_resolve['size'], constant_resolve['time'], label='Execution time for resolve_indirect_jumps on synthetic BIR programs') +plt.xlabel('Program size (middle blocks)') +plt.ylabel('Time (seconds)') +plt.title('Experiment 3') +plt.legend() +plt.savefig('constant_resolve.png') + +plt.figure() + + transfer = np.genfromtxt('transfer', delimiter=',', names=['size', 'time']) -plt.plot(transfer['size'], transfer['time'], label='Execution time for transfer_contract on synthetic programs') +plt.plot(transfer['size'], transfer['time'], label='Execution time for transfer_contract on synthetic BIR programs') plt.xlabel('Program size (middle blocks)') plt.ylabel('Time (seconds)') -plt.title('transfer_contract benchmark') +plt.title('Experiment 4') plt.legend() plt.savefig('transfer.png') diff --git a/examples/ijr/resolutionScript.sml b/examples/ijr/resolutionScript.sml index 0cdd105d9..ad2ee51c1 100644 --- a/examples/ijr/resolutionScript.sml +++ b/examples/ijr/resolutionScript.sml @@ -106,22 +106,22 @@ End (*Any value besides 1w is fine*) Definition assert_block_def: - assert_block l bss v = + assert_block l bss es = <| bb_label := l; bb_statements := bss ++ [BStmt_Assert (BExp_Const (Imm1 0w))]; - bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address v)) |> + bb_last_statement := es|> End Inductive resolved_fail_block: - ∀l v bl1 bl2 e. + ∀l bl1 bl2 e. bl1 = bir_block_t l bss (BStmt_Jmp (BLE_Exp e)) ∧ - bl2 = assert_block l bss v ⇒ - resolved_fail_block l v bl1 bl2 + bl2 = assert_block l bss es ⇒ + resolved_fail_block l bl1 bl2 End Theorem resolved_fail_block_labels: - ∀l v bl1 bl2. - resolved_fail_block l v bl1 bl2 ⇒ + ∀l bl1 bl2. + resolved_fail_block l bl1 bl2 ⇒ bl1.bb_label = l ∧ bl2.bb_label = l Proof REPEAT STRIP_TAC >> @@ -130,8 +130,9 @@ FULL_SIMP_TAC (std_ss++holBACore_ss) QED Theorem resolved_fail_block_vars: - ∀l v bl1 bl2. - resolved_fail_block l v bl1 bl2 ⇒ + ∀l bl1 bl2. + bir_vars_of_stmtE bl2.bb_last_statement = {} ⇒ + resolved_fail_block l bl1 bl2 ⇒ bir_vars_of_block bl2 SUBSET bir_vars_of_block bl1 Proof REPEAT STRIP_TAC >> @@ -142,18 +143,18 @@ FULL_SIMP_TAC (list_ss++PRED_SET_ss++holBACore_ss) QED Inductive resolved_fail: - ∀l1 v p p' bl1 bl2. + ∀l1 p p' bl1 bl2. (∀l. MEM l (bir_labels_of_program p') ⇔ MEM l (bir_labels_of_program p)) ∧ bir_get_current_block p (bir_block_pc l1) = SOME bl1 ∧ bir_get_current_block p' (bir_block_pc l1) = SOME bl2 ∧ - resolved_fail_block l1 v bl1 bl2 ∧ + resolved_fail_block l1 bl1 bl2 ∧ (∀l. MEM l (bir_labels_of_program p) ∧ l ≠ l1 ⇒ ∃bl. bir_get_current_block p (bir_block_pc l) = SOME bl ∧ bir_get_current_block p' (bir_block_pc l) = SOME bl) ⇒ - resolved_fail l1 v p p' + resolved_fail l1 p p' End diff --git a/examples/ijr/resolveFullyLib.sml b/examples/ijr/resolveFullyLib.sml index 5aba23db7..31ace017b 100644 --- a/examples/ijr/resolveFullyLib.sml +++ b/examples/ijr/resolveFullyLib.sml @@ -2,12 +2,13 @@ structure resolveFullyLib = struct open HolKernel Parse boolLib bossLib; -open optionSyntax bir_htSyntax; +open optionSyntax bir_htSyntax bir_wm_instSyntax; open bir_wp_interfaceLib; open tutorial_smtSupportLib; open bir_compositionLib; +open listTheory; open resolveFullyTheory; open timersLib; @@ -23,7 +24,7 @@ fun resolve_indirect_jumps(prog'_name, prog_tm, args) = (prog'_def, prog'_thm') end -fun transfer_contract(prog'_thm, ht_thm) = +fun transfer_bir_exec_to_labels_triple(prog'_thm, ht_thm) = let val prog_tm = (el 1 o snd o strip_comb o lhs o concl) prog'_thm val ht_tm = concl ht_thm @@ -41,8 +42,37 @@ fun transfer_contract(prog'_thm, ht_thm) = MATCH_MP res_thm ht_thm end +fun transfer_contract(prog'_thm, ht_thm) = + let + val prog_tm = (el 1 o snd o strip_comb o lhs o concl) prog'_thm + val ht_tm = concl ht_thm + val (_, _, entry_tm, wl_tm, bl_tm, _, _) = dest_bir_simp_jgmt ht_tm + val entry_thm = prove ( + “MEM ^entry_tm (bir_labels_of_program ^prog_tm)”, + EVAL_TAC) + val wl_thm = prove ( + “^wl_tm SUBSET (set (bir_labels_of_program ^prog_tm))”, + EVAL_TAC) + val bl_thm = prove ( + “^bl_tm SUBSET (set (bir_labels_of_program ^prog_tm))”, + EVAL_TAC) + val res_thm = MATCH_MP resolve_fully_n_bir_simp_jgmt_transfer prog'_thm + val res_thm = MATCH_MP res_thm entry_thm + val res_thm = MATCH_MP res_thm wl_thm + val res_thm = MATCH_MP res_thm bl_thm + in + MATCH_MP res_thm ht_thm + end + fun prove_and_transfer_contract(prog'_thm, prefix, pre_tm, entry_label_tm, ending_labels_tm, post_tm, defs) = let + (*Add exit points*) + val args_tm = (el 2 o snd o strip_comb o lhs o concl) prog'_thm + val bl_tm1 = EVAL “set (MAP (BL_Label o SND o LAST o SND) ^args_tm)” + val bl_tm2 = REWRITE_RULE [LIST_TO_SET] bl_tm1 + val bl_tm3 = (rhs o concl) bl_tm2 + val ending_labels_tm = (rhs o concl o EVAL) “^ending_labels_tm UNION ^bl_tm3” + val wp_start = timer_start () val prog'_tm = (dest_some o rhs o concl) prog'_thm (*Obtain WP contract*) @@ -54,23 +84,27 @@ fun prove_and_transfer_contract(prog'_thm, prefix, pre_tm, entry_label_tm, endin prefix defs val _ = print ("WP time: " ^ timer_stop_str wp_start ^ "\n") + (*Simplify WP contract*) val wp_var = mk_var(prefix ^ "_wp", type_of wp_tm) val wp_def = Define `^(wp_var) = ^(wp_tm)` val ht_thm' = REWRITE_RULE [GSYM wp_def] ht_thm - (*Transfer WP contract*) - val transfer_start = timer_start () - val ht'_thm = transfer_contract(prog'_thm, ht_thm') - val _ = print ("Transfer time: " ^ timer_stop_str transfer_start ^ "\n") - (*Prove implication using SMT solvers*) val smt_start = timer_start () val contract_imp = bimp (pre_tm, (lhs o concl) wp_def) val contract_imp_taut_thm = prove_exp_is_taut contract_imp - val res = label_ct_to_simp_ct_predset ht'_thm contract_imp_taut_thm + val contract = label_ct_to_simp_ct_predset ht_thm' contract_imp_taut_thm val _ = print ("SMT time: " ^ timer_stop_str smt_start ^ "\n") + + (*Remove new exit points*) + val contract = bir_remove_labels_from_blist_predset contract bl_tm3 + + (*Transfer WP contract*) + val transfer_start = timer_start () + val contract = transfer_contract(prog'_thm, contract) + val _ = print ("Transfer time: " ^ timer_stop_str transfer_start ^ "\n") in - res + contract end end diff --git a/examples/ijr/resolveFullyScript.sml b/examples/ijr/resolveFullyScript.sml index 8165071e5..470a3183b 100644 --- a/examples/ijr/resolveFullyScript.sml +++ b/examples/ijr/resolveFullyScript.sml @@ -1,4 +1,4 @@ -open HolKernel Parse boolLib bossLib; +open HolKernel Parse boolLib bossLib BasicProvers; open listTheory optionTheory pred_setTheory pred_setSimps; @@ -20,70 +20,66 @@ Definition direct_jump_targets_block_compute_def: | _ => [] End -Theorem direct_jump_target_block_direct_jump_targets_block_compute: - ∀l bl. - direct_jump_target_block l bl ⇒ - MEM l (direct_jump_targets_block_compute bl) -Proof -SIMP_TAC std_ss [direct_jump_target_block_def] >> -REPEAT STRIP_TAC >- ( - ASM_SIMP_TAC (list_ss++bir_TYPES_ss) [direct_jump_targets_block_compute_def] -) >- ( - Cases_on ‘l2’ >> - ASM_SIMP_TAC (list_ss++bir_TYPES_ss) [direct_jump_targets_block_compute_def] -) >> -Cases_on ‘l1’ >> -ASM_SIMP_TAC (list_ss++bir_TYPES_ss) [direct_jump_targets_block_compute_def] -QED - -Definition direct_jump_targets_compute_def: - direct_jump_targets_compute (BirProgram bls) = - LIST_BIND bls direct_jump_targets_block_compute -End - -Theorem direct_jump_target_direct_jump_targets_compute: - ∀l p. direct_jump_target l p ⇒ - MEM l (direct_jump_targets_compute p) -Proof -Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> -SIMP_TAC std_ss [direct_jump_target_def] >> -REPEAT STRIP_TAC >> -SIMP_TAC list_ss [direct_jump_targets_compute_def, LIST_BIND_def, MEM_FLAT, MEM_MAP] >> -Q.EXISTS_TAC ‘direct_jump_targets_block_compute bl’ >> -STRIP_TAC >- ( - Q.EXISTS_TAC ‘bl’ >> - ASM_SIMP_TAC std_ss [MEM_EL] >> - PROVE_TAC [bir_get_program_block_info_by_label_THM, bir_get_current_block_SOME] -) >> - -IMP_RES_TAC direct_jump_target_block_direct_jump_targets_block_compute -QED - Definition fresh_label_compute_def: - fresh_label_compute l p = - (~(MEM l (bir_labels_of_program p)) ∧ - ~(MEM l (direct_jump_targets_compute p))) + (fresh_label_compute l (BirProgram []) = T) ∧ + (fresh_label_compute l (BirProgram (bl::bls)) = + (~(bl.bb_label = l) ∧ + ~(MEM l (direct_jump_targets_block_compute bl)) ∧ + fresh_label_compute l (BirProgram bls))) End Theorem fresh_label_compute_sound: ∀l p. fresh_label_compute l p ⇒ fresh_label l p Proof +Cases_on ‘p’ >> rename1 ‘BirProgram bls’ >> +Induct_on ‘bls’ >- ( + SIMP_TAC list_ss [fresh_label_def, bir_labels_of_program_def, + direct_jump_target_def, bir_get_current_block_def, + bir_get_program_block_info_by_label_def, INDEX_FIND_def] +) >> + SIMP_TAC std_ss [fresh_label_compute_def, fresh_label_def] >> -REPEAT STRIP_TAC >> -PROVE_TAC [direct_jump_target_direct_jump_targets_compute] +NTAC 4 STRIP_TAC >> +‘fresh_label l (BirProgram bls)’ by PROVE_TAC [] >- ( + SIMP_TAC list_ss [bir_labels_of_program_def] >> + PROVE_TAC [bir_labels_of_program_def, fresh_label_def] +) >> + +SIMP_TAC std_ss [direct_jump_target_def] >> +REPEAT GEN_TAC >> +SIMP_TAC (std_ss++bir_TYPES_ss) [bir_get_current_block_def, + bir_get_program_block_info_by_label_def, + INDEX_FIND_def, bir_block_pc_def] >> +CASE_TAC >- ( + FULL_SIMP_TAC std_ss [direct_jump_target_block_def, + direct_jump_targets_block_compute_def] >> + DISCH_THEN SUBST_ALL_TAC >> + EVERY_CASE_TAC >> + FULL_SIMP_TAC (list_ss++bir_TYPES_ss) [] +) >> + +FULL_SIMP_TAC (list_ss++bir_TYPES_ss) [fresh_label_def, direct_jump_target_def, + bir_get_current_block_def, bir_block_pc_def, + bir_get_program_block_info_by_label_def] >> +SIMP_TAC std_ss [Once bir_auxiliaryTheory.INDEX_FIND_INDEX_CHANGE] >> +Q.PAT_X_ASSUM ‘∀l'' bl. _’ (MP_TAC o Q.SPECL [‘l'’, ‘bl’]) >> +EVERY_CASE_TAC >> +FULL_SIMP_TAC std_ss [] >> +Cases_on ‘x’ >> +FULL_SIMP_TAC std_ss [] QED Definition resolve_fully_def: - (resolve_fully p l [] v = resolve_fail p l v) ∧ - (resolve_fully p l ((v, sl) :: xs) v' = + (resolve_fully p l [] = resolve_fail p l) ∧ + (resolve_fully p l ((v, sl) :: xs) = if fresh_label_compute (BL_Label sl) p then - OPTION_BIND (resolve p l v sl) (\p'. resolve_fully p' (BL_Label sl) xs v') + OPTION_BIND (resolve p l v sl) (\p'. resolve_fully p' (BL_Label sl) xs) else NONE) End Theorem resolve_fully_simulated_termination: - ∀p l xs v' p'. - resolve_fully p l xs v' = SOME p' ⇒ + ∀p l xs p'. + resolve_fully p l xs = SOME p' ⇒ simulated_termination p p' Proof Induct_on ‘xs’ >> @@ -99,8 +95,8 @@ PROVE_TAC [resolve_simulated_termination, fresh_label_compute_sound, QED Theorem resolve_fully_vars: - ∀p l xs v' p'. - resolve_fully p l xs v' = SOME p' ⇒ + ∀p l xs p'. + resolve_fully p l xs = SOME p' ⇒ bir_vars_of_program p' SUBSET bir_vars_of_program p Proof Induct_on ‘xs’ >> @@ -115,8 +111,8 @@ PROVE_TAC [resolve_vars, SUBSET_TRANS] QED Theorem resolve_fully_labels: - ∀p l xs v' p'. - resolve_fully p l xs v' = SOME p' ⇒ + ∀p l xs p'. + resolve_fully p l xs = SOME p' ⇒ set (bir_labels_of_program p) SUBSET set (bir_labels_of_program p') Proof Induct_on ‘xs’ >> @@ -132,8 +128,8 @@ QED Definition resolve_fully_n_def: (resolve_fully_n p [] = SOME p) ∧ - (resolve_fully_n p ((l, xs, v) :: ys) = - OPTION_BIND (resolve_fully p l xs v) (\p'. resolve_fully_n p' ys)) + (resolve_fully_n p ((l, xs) :: ys) = + OPTION_BIND (resolve_fully p l xs) (\p'. resolve_fully_n p' ys)) End Theorem resolve_fully_n_simulated_termination: @@ -147,7 +143,7 @@ REPEAT GEN_TAC >- ( ) >> rename1 ‘SOME p''’ >> -Cases_on ‘h’ >> Cases_on ‘r’ >> rename1 ‘(l, xs, v)’ >> +Cases_on ‘h’ >> Cases_on ‘r’ >> rename1 ‘(l, xs)’ >> SIMP_TAC std_ss [resolve_fully_n_def] >> PROVE_TAC [resolve_fully_simulated_termination, resolve_fully_labels, simulated_termination_transitive] @@ -164,7 +160,7 @@ REPEAT GEN_TAC >- ( ) >> rename1 ‘SOME p''’ >> -Cases_on ‘h’ >> Cases_on ‘r’ >> rename1 ‘(l, xs, v)’ >> +Cases_on ‘h’ >> Cases_on ‘r’ >> rename1 ‘(l, xs)’ >> SIMP_TAC std_ss [resolve_fully_n_def] >> PROVE_TAC [resolve_fully_vars, SUBSET_TRANS] QED @@ -183,6 +179,21 @@ PROVE_TAC [resolve_fully_n_simulated_termination, resolve_fully_n_vars, contract_transfer] QED +Theorem resolve_fully_n_bir_simp_jgmt_transfer: + ∀p ys p' i l ls ls' pre post. + resolve_fully_n p ys = SOME p' ⇒ + + MEM l (bir_labels_of_program p) ⇒ + ls SUBSET (set (bir_labels_of_program p)) ⇒ + ls' SUBSET (set (bir_labels_of_program p)) ⇒ + + bir_simp_jgmt p' i l ls ls' pre post ⇒ + bir_simp_jgmt p i l ls ls' pre post +Proof +PROVE_TAC [resolve_fully_n_simulated_termination, + resolve_fully_n_vars, bir_simp_jgmt_transfer] +QED + val _ = export_theory(); diff --git a/examples/ijr/resolveScript.sml b/examples/ijr/resolveScript.sml index ef7cee20d..3362db2c6 100644 --- a/examples/ijr/resolveScript.sml +++ b/examples/ijr/resolveScript.sml @@ -1,4 +1,4 @@ -open HolKernel Parse boolLib bossLib; +open HolKernel Parse boolLib bossLib BasicProvers; open listTheory optionTheory pred_setTheory pred_setSimps; @@ -228,41 +228,46 @@ QED Definition resolve_fail_block_def: - (resolve_fail_block bl v = + (resolve_fail_block bl = case bl.bb_last_statement of BStmt_Jmp (BLE_Exp e) => - SOME [assert_block bl.bb_label bl.bb_statements v] + SOME [assert_block bl.bb_label bl.bb_statements (BStmt_Halt (BExp_Const (Imm1 0w)))] | _ => NONE) End Theorem resolve_fail_block_sound: - ∀bl1 v r. - resolve_fail_block bl1 v = SOME r ⇒ + ∀bl1 r. + resolve_fail_block bl1 = SOME r ⇒ (∃bl2. r = [bl2] ∧ - resolved_fail_block (bl1.bb_label) v bl1 bl2) + resolved_fail_block (bl1.bb_label) bl1 bl2) Proof REPEAT GEN_TAC >> Cases_on ‘bl1’ >> rename1 ‘bir_block_t l1 bss es’ >> -Cases_on ‘es’ >> SIMP_TAC (std_ss++holBACore_ss) [resolve_fail_block_def] >> -rename1 ‘BStmt_Jmp e’ >> -Cases_on ‘e’ >> -SIMP_TAC (std_ss++holBACore_ss) [resolved_fail_block_cases] +REPEAT CASE_TAC >> +SIMP_TAC (std_ss++holBACore_ss) [resolved_fail_block_cases] >> +PROVE_TAC [] QED Theorem resolve_fail_block_refines_vars: - ∀v. refines_vars (\bl. resolve_fail_block bl v) + refines_vars resolve_fail_block Proof SIMP_TAC std_ss [refines_vars_def] >> -REPEAT GEN_TAC >> -DISCH_THEN (STRIP_ASSUME_TAC o MATCH_MP resolve_fail_block_sound) >> +REPEAT STRIP_TAC >> +IMP_RES_TAC resolve_fail_block_sound >> ASM_SIMP_TAC (list_ss++PRED_SET_ss) [] >> +subgoal ‘bir_vars_of_stmtE bl2.bb_last_statement = ∅’ >- ( + FULL_SIMP_TAC std_ss [resolve_fail_block_def] >> + EVERY_CASE_TAC >> + FULL_SIMP_TAC std_ss [assert_block_def] >> + RW_TAC (std_ss++holBACore_ss) [bir_vars_of_stmtE_def] +) >> PROVE_TAC [resolved_fail_block_vars] QED Definition resolve_fail_def: - resolve_fail p l v = replace_block p l (\bl. resolve_fail_block bl v) + resolve_fail p l = replace_block p l resolve_fail_block End Theorem EXISTS_MEM_labels: @@ -275,9 +280,9 @@ PROVE_TAC [] QED Theorem resolve_fail_sound: - ∀p l p' v. - resolve_fail p l v = SOME p' ⇒ - resolved_fail l v p p' + ∀p l p'. + resolve_fail p l = SOME p' ⇒ + resolved_fail l p p' Proof REPEAT GEN_TAC >> Cases_on ‘p’ >> rename1 ‘BirProgram p’ >> @@ -322,8 +327,8 @@ REPEAT STRIP_TAC >| [ QED Theorem resolve_fail_simulated_termination: - ∀p l v p'. - resolve_fail p l v = SOME p' ⇒ + ∀p l p'. + resolve_fail p l = SOME p' ⇒ simulated_termination p p' Proof PROVE_TAC [resolve_fail_sound, @@ -332,8 +337,8 @@ PROVE_TAC [resolve_fail_sound, QED Theorem resolve_fail_vars: - ∀p l v p'. - resolve_fail p l v = SOME p' ⇒ + ∀p l p'. + resolve_fail p l = SOME p' ⇒ bir_vars_of_program p' SUBSET bir_vars_of_program p Proof METIS_TAC [resolve_fail_def, replace_block_SOME_vars, @@ -341,8 +346,8 @@ METIS_TAC [resolve_fail_def, replace_block_SOME_vars, QED Theorem resolve_fail_labels: - ∀p l v p'. - resolve_fail p l v = SOME p' ⇒ + ∀p l p'. + resolve_fail p l = SOME p' ⇒ bir_labels_of_program p = bir_labels_of_program p' Proof REPEAT GEN_TAC >> diff --git a/examples/ijr/simulationFailScript.sml b/examples/ijr/simulationFailScript.sml index 0cd874be8..ce244f7d9 100644 --- a/examples/ijr/simulationFailScript.sml +++ b/examples/ijr/simulationFailScript.sml @@ -44,9 +44,9 @@ Q.PAT_X_ASSUM ‘_ = s2’ (fn thm => ASM_SIMP_TAC (std_ss++holBACore_ss) [GSYM QED Theorem bir_exec_block_assert_jmp: - ∀p' p l1 bss e s v s2 s1 os2 m2 os1 m1 bl1 bl2. + ∀p' p l1 bss es e s s2 s1 os2 m2 os1 m1 bl1 bl2. bl1 = bir_block_t l1 bss (BStmt_Jmp (BLE_Exp e)) ⇒ - bl2 = assert_block l1 bss v ⇒ + bl2 = assert_block l1 bss es ⇒ bir_exec_block p' bl2 s = (os2, m2, s2) ⇒ bir_exec_block p bl1 s = (os1, m1, s1) ⇒ @@ -63,7 +63,7 @@ ASM_SIMP_TAC (std_ss++holBACore_ss) [assert_block_def, bir_exec_block_def] >> by PROVE_TAC [pairTheory.PAIR] >> ‘∃os1 m1 s1. bir_exec_stmtsB bss ([],0,s) = (os1, m1, s1)’ by PROVE_TAC [pairTheory.PAIR] >> -Q.ABBREV_TAC ‘s2' = bir_exec_stmtE p' (BStmt_Jmp (BLE_Label (BL_Address v))) s2’ >> +Q.ABBREV_TAC ‘s2' = bir_exec_stmtE p' es s2’ >> Q.ABBREV_TAC ‘s1' = bir_exec_stmtE p (BStmt_Jmp (BLE_Exp e)) s1’ >> FULL_SIMP_TAC std_ss [LET_DEF] >> @@ -81,8 +81,8 @@ FULL_SIMP_TAC (std_ss++holBACore_ss) [] QED Theorem resolved_fail_simulated_fail: - ∀l1 v p p'. - resolved_fail l1 v p p' ⇒ + ∀l1 p p'. + resolved_fail l1 p p' ⇒ simulated_fail p p' Proof REPEAT GEN_TAC >> STRIP_TAC >> @@ -129,7 +129,7 @@ POP_ASSUM SUBST_ALL_TAC >> ‘∃bl1 bl2. bir_get_current_block p s.bst_pc = SOME bl1 ∧ bir_get_current_block p' s.bst_pc = SOME bl2 ∧ - resolved_fail_block l1 v bl1 bl2’ by ( + resolved_fail_block l1 bl1 bl2’ by ( FULL_SIMP_TAC std_ss [resolved_fail_cases] ) >> FULL_SIMP_TAC std_ss [resolved_fail_block_cases] >> diff --git a/src/tools/comp/bir_compositionLib.sml b/src/tools/comp/bir_compositionLib.sml index 6a50331a9..77718941a 100644 --- a/src/tools/comp/bir_compositionLib.sml +++ b/src/tools/comp/bir_compositionLib.sml @@ -292,7 +292,7 @@ open bir_inst_liftingHelpersLib; HO_MATCH_MP new_map_triple3 (SIMP_RULE std_ss [] elabel_post_is_false_thm) (* Finalize with assumption and INSERT and DELETE simplification *) val new_map_triple5 = - SIMP_RULE std_ss [ASSUME assmpt] + SIMP_RULE (std_ss++stringSimps.STRING_ss++string_ss) [ASSUME assmpt] (simp_delete_set_repr_rule new_map_triple4) val new_map_triple6 = simp_insert_set_repr_rule new_map_triple5 From d68b0ed45906676bf7faad0d9c173d570a9d578e Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Wed, 30 Jun 2021 09:10:55 +0200 Subject: [PATCH 0060/1015] Add (now passing) test case from PR to test suite --- src/tools/comp/examples/Holmakefile.gen | 16 +++++++++++++++ .../test-bir_populate_blacklist_predset.sml | 20 +++++++++++++++++++ 2 files changed, 36 insertions(+) create mode 100644 src/tools/comp/examples/Holmakefile.gen create mode 100644 src/tools/comp/examples/test-bir_populate_blacklist_predset.sml diff --git a/src/tools/comp/examples/Holmakefile.gen b/src/tools/comp/examples/Holmakefile.gen new file mode 100644 index 000000000..16f6684d2 --- /dev/null +++ b/src/tools/comp/examples/Holmakefile.gen @@ -0,0 +1,16 @@ +# includes +# ---------------------------------- +DEPENDENCIES = + + +# configuration +# ---------------------------------- +HOLHEAP = ../HolBATools_Comp-heap +NEWHOLHEAP = + +HEAPINC_EXTRA = + + +# included lines follow +# ---------------------------------- +include ../../../Holmakefile.inc diff --git a/src/tools/comp/examples/test-bir_populate_blacklist_predset.sml b/src/tools/comp/examples/test-bir_populate_blacklist_predset.sml new file mode 100644 index 000000000..323419ede --- /dev/null +++ b/src/tools/comp/examples/test-bir_populate_blacklist_predset.sml @@ -0,0 +1,20 @@ +open HolKernel Parse boolLib bossLib; +open bslSyntax; +open bir_compositionLib; +open bir_bool_expTheory; + +val observe_type = Type `: 'a` +val bdefprog_list = bdefprog_list observe_type + +val p_def = bdefprog_list "p" [(blabel_str "entry", [], (bjmp o belabel_str) "0w"), + (blabel_str "0w", [], (bjmp o belabel_str) "1w"), + (blabel_str "1w", [], (bjmp o belabel_addr64) 2), + (blabel_addr64 2, [], (bhalt o bconst64) 0)] + +val post = ``(\l. if (l = BL_Address (Imm64 2w)) then bir_exp_true else bir_exp_false)`` +val c = prove( + ``bir_simp_jgmt p bir_exp_true (BL_Label "entry") {BL_Address (Imm64 2w) ; BL_Label "0w" ; BL_Label "1w"} {} bir_exp_true ^post``, + cheat) + +(*Check that string labels are handled correctly*) +val c' = bir_populate_blacklist_predset c \ No newline at end of file From 1572da11bb33848f977fe5a52b8ed2d5a2418165 Mon Sep 17 00:00:00 2001 From: Gwin73 Date: Fri, 2 Jul 2021 13:46:53 +0200 Subject: [PATCH 0061/1015] Rename theorems --- examples/ijr/contractTransferScript.sml | 4 ++-- examples/ijr/resolveFullyLib.sml | 4 ++-- examples/ijr/resolveFullyScript.sml | 8 ++++---- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/examples/ijr/contractTransferScript.sml b/examples/ijr/contractTransferScript.sml index 4ca43fcc8..c5d35f285 100644 --- a/examples/ijr/contractTransferScript.sml +++ b/examples/ijr/contractTransferScript.sml @@ -444,7 +444,7 @@ subgoal ‘∃os1' m1' n1'. bir_exec_to_labels ls p s = BER_Ended os1' m1' n1' s PROVE_TAC [] QED -Theorem contract_transfer: +Theorem bir_exec_to_labels_triple_transfer: ∀ p p' l ls pre post. simulated_termination p p' ⇒ (bir_vars_of_program p') SUBSET (bir_vars_of_program p) ⇒ @@ -480,7 +480,7 @@ subgoal ‘∃s1 o1 m1 n1. bir_exec_to_labels ls p s = ASM_SIMP_TAC (std_ss++holBACore_ss) [] QED -Theorem bir_simp_jgmt_transfer: +Theorem contract_transfer: ∀ p p' i l ls ls' pre post. simulated_termination p p' ⇒ (bir_vars_of_program p') SUBSET (bir_vars_of_program p) ⇒ diff --git a/examples/ijr/resolveFullyLib.sml b/examples/ijr/resolveFullyLib.sml index 31ace017b..6f72cc195 100644 --- a/examples/ijr/resolveFullyLib.sml +++ b/examples/ijr/resolveFullyLib.sml @@ -35,7 +35,7 @@ fun transfer_bir_exec_to_labels_triple(prog'_thm, ht_thm) = val ending_thm = prove ( “^exits_tm SUBSET (set (bir_labels_of_program ^prog_tm))”, EVAL_TAC) - val res_thm = MATCH_MP resolve_fully_n_contract_transfer prog'_thm + val res_thm = MATCH_MP resolve_fully_n_bir_exec_to_labels_triple_transfer prog'_thm val res_thm = MATCH_MP res_thm entry_thm val res_thm = MATCH_MP res_thm ending_thm in @@ -56,7 +56,7 @@ fun transfer_contract(prog'_thm, ht_thm) = val bl_thm = prove ( “^bl_tm SUBSET (set (bir_labels_of_program ^prog_tm))”, EVAL_TAC) - val res_thm = MATCH_MP resolve_fully_n_bir_simp_jgmt_transfer prog'_thm + val res_thm = MATCH_MP resolve_fully_n_contract_transfer prog'_thm val res_thm = MATCH_MP res_thm entry_thm val res_thm = MATCH_MP res_thm wl_thm val res_thm = MATCH_MP res_thm bl_thm diff --git a/examples/ijr/resolveFullyScript.sml b/examples/ijr/resolveFullyScript.sml index 470a3183b..6ac582058 100644 --- a/examples/ijr/resolveFullyScript.sml +++ b/examples/ijr/resolveFullyScript.sml @@ -165,7 +165,7 @@ SIMP_TAC std_ss [resolve_fully_n_def] >> PROVE_TAC [resolve_fully_vars, SUBSET_TRANS] QED -Theorem resolve_fully_n_contract_transfer: +Theorem resolve_fully_n_bir_exec_to_labels_triple_transfer: ∀p ys p' l ls pre post. resolve_fully_n p ys = SOME p' ⇒ @@ -176,10 +176,10 @@ Theorem resolve_fully_n_contract_transfer: bir_exec_to_labels_triple p l ls pre post Proof PROVE_TAC [resolve_fully_n_simulated_termination, - resolve_fully_n_vars, contract_transfer] + resolve_fully_n_vars, bir_exec_to_labels_triple_transfer] QED -Theorem resolve_fully_n_bir_simp_jgmt_transfer: +Theorem resolve_fully_n_contract_transfer: ∀p ys p' i l ls ls' pre post. resolve_fully_n p ys = SOME p' ⇒ @@ -191,7 +191,7 @@ Theorem resolve_fully_n_bir_simp_jgmt_transfer: bir_simp_jgmt p i l ls ls' pre post Proof PROVE_TAC [resolve_fully_n_simulated_termination, - resolve_fully_n_vars, bir_simp_jgmt_transfer] + resolve_fully_n_vars, contract_transfer] QED From c99a0215865863fedff199788f7a11566d588560 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Tue, 27 Jul 2021 10:43:57 +0200 Subject: [PATCH 0062/1015] Quick and dirty BIR eval with EVAL --- src/shared/bir_evalLib.sig | 6 ++++++ src/shared/bir_evalLib.sml | 23 +++++++++++++++++++++++ 2 files changed, 29 insertions(+) create mode 100644 src/shared/bir_evalLib.sig create mode 100644 src/shared/bir_evalLib.sml diff --git a/src/shared/bir_evalLib.sig b/src/shared/bir_evalLib.sig new file mode 100644 index 000000000..d80f4e863 --- /dev/null +++ b/src/shared/bir_evalLib.sig @@ -0,0 +1,6 @@ +signature bir_evalLib = +sig + include Abbrev; + val bir_eval_exec : term -> term -> term list * term + +end diff --git a/src/shared/bir_evalLib.sml b/src/shared/bir_evalLib.sml new file mode 100644 index 000000000..40b035040 --- /dev/null +++ b/src/shared/bir_evalLib.sml @@ -0,0 +1,23 @@ +structure bir_evalLib :> bir_evalLib = +struct + +open HolKernel Parse boolLib bossLib bir_programSyntax pairSyntax optionSyntax; + +fun cons_obs_tm ob_o (obs,st) = + if is_none ob_o + then (obs,st) + else (dest_some ob_o :: obs, st) + +fun bir_eval_exec prog st = + let val (_,_,status) = dest_bir_state st; + in + if not (is_BST_Running status) + then ([], st) + else + let val (ob_tm, st') = (dest_pair o rhs o concl) (EVAL “bir_exec_step ^prog ^st”) + in + cons_obs_tm ob_tm (bir_eval_exec prog st') + end + end; + +end From ec9b12953ac81413e8c41ecb3625b7302851806c Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Tue, 27 Jul 2021 12:28:51 +0200 Subject: [PATCH 0063/1015] Fix --- src/tools/lifter/examples/aes-test.sml | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/tools/lifter/examples/aes-test.sml b/src/tools/lifter/examples/aes-test.sml index 8244797a6..f9ab08576 100644 --- a/src/tools/lifter/examples/aes-test.sml +++ b/src/tools/lifter/examples/aes-test.sml @@ -1,7 +1,11 @@ open HolKernel Parse open bir_inst_liftingLib; -open gcc_supportLib +open gcc_supportLib; + +open PPBackEnd; +open bir_inst_liftingHelpersLib; + val _ = Parse.current_backend := PPBackEnd.vt100_terminal; val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; @@ -11,7 +15,14 @@ val _ = print_with_style_ [Bold, Underline] "Lifting aes-aarch64.da\n"; val (region_map, aes_sections) = read_disassembly_file_regions "aes-aarch64.da" val (thm_arm8, errors) = bmil_arm8.bir_lift_prog_gen ((Arbnum.fromInt 0), (Arbnum.fromInt 0x1000000)) - aes_sections + aes_sections; + +(* + +val prog_l = (snd o dest_comb o concl) thm_arm8; + +val prog_l_norm = (rhs o concl o EVAL) prog_l; +*) val _ = print "\n\n\n"; From 9b73e4e0df1513e1a3521f85989b988a2fb3845a Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Mon, 26 Jul 2021 18:37:15 +0200 Subject: [PATCH 0064/1015] Testing angr integration lib --- src/tools/scamv/symbexec/bir_angrLib.sml | 46 ++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 src/tools/scamv/symbexec/bir_angrLib.sml diff --git a/src/tools/scamv/symbexec/bir_angrLib.sml b/src/tools/scamv/symbexec/bir_angrLib.sml new file mode 100644 index 000000000..3f6517f24 --- /dev/null +++ b/src/tools/scamv/symbexec/bir_angrLib.sml @@ -0,0 +1,46 @@ +structure bir_angrLib = +struct + +open HolKernel Parse Abbrev; + +(* error handling *) +val libname = "bir_angrLib" +val ERR = Feedback.mk_HOL_ERR libname +val wrap_exn = Feedback.wrap_exn libname + +(* path to fence_insertion repo + intended usage by default is to have a symlink in the fs +*) +val fence_insertion_repo_path = "angr_platforms/bir"; + + +val bir_program = ``BirProgram + [<|bb_label := BL_Address_HC (Imm64 0w) "F9400023 (ldr x3, [x1])"; + bb_statements := + [BStmt_Assert + (BExp_Const (Imm1 abc)); + BStmt_Assign (BVar "R3" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R1" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64); + BStmt_Observe 0 (BExp_Const (Imm1 1w)) + [BExp_BinExp BIExp_And + (BExp_Const (Imm64 0x1FC0w)) + (BExp_Den (BVar "R1" (BType_Imm Bit64)))] + HD]; + bb_last_statement := BStmt_Halt (BExp_Const (Imm64 4w))|>]``; + +(* some arguments ignored for now: + maxdepth, precondition, pd, envupdate_o +*) +fun symb_exec_program maxdepth precondition program pd envupdate_o = + let open bir_fileLib bir_exec_wrapLib; + val bir_program_filename = get_tempfile "program" ".bir"; + val _ = write_to_file bir_program_filename (term_to_string program); + val python_script_filename = fence_insertion_repo_path ^ "/symbolic_execution.py"; + val output = get_exec_output_list ("python3 " ^ python_script_filename ^ " " ^ bir_program_filename); + in + output + end; + +end From 9efac1372dc4fa072ca1d4245f2c4be458015895 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Tue, 27 Jul 2021 14:53:57 +0200 Subject: [PATCH 0065/1015] Library to convert SCAM-V machine states into BIR states --- src/tools/scamv/bir_machstate_importLib.sig | 10 ++++ src/tools/scamv/bir_machstate_importLib.sml | 56 +++++++++++++++++++++ 2 files changed, 66 insertions(+) create mode 100644 src/tools/scamv/bir_machstate_importLib.sig create mode 100644 src/tools/scamv/bir_machstate_importLib.sml diff --git a/src/tools/scamv/bir_machstate_importLib.sig b/src/tools/scamv/bir_machstate_importLib.sig new file mode 100644 index 000000000..e3e2a1bd3 --- /dev/null +++ b/src/tools/scamv/bir_machstate_importLib.sig @@ -0,0 +1,10 @@ +signature bir_machstate_importLib = +sig + include Abbrev; + val merge_machstate_into_bir_state : term -> experimentsLib.machineState -> term; + val merge_json_into_bir_state : term -> Json.json -> term; + + (* first argument is the program (to initialise PC, etc.) *) + val scamv_machstate_to_bir_state : term -> experimentsLib.machineState -> term; + val scamv_json_to_bir_state : term -> Json.json -> term; +end diff --git a/src/tools/scamv/bir_machstate_importLib.sml b/src/tools/scamv/bir_machstate_importLib.sml new file mode 100644 index 000000000..cbc93f043 --- /dev/null +++ b/src/tools/scamv/bir_machstate_importLib.sml @@ -0,0 +1,56 @@ +structure bir_machstate_importLib :> bir_machstate_importLib = +struct +open HolKernel Parse boolLib bossLib Abbrev; + +local + open wordsSyntax numSyntax pairSyntax; + open experimentsLib; + + (* main memory name in BIR env *) + val mem_string = “"MEM"”; + + (* defval ignored for now *) + fun build_mem wsz defval memmap = + let open bir_immSyntax bir_valuesSyntax finite_mapSyntax; + val value_ty = bir_immtype_t_of_size wsz; + val mf_empty = mk_fempty (num, num); + fun mk_fupdate_pair (addr,v) = mk_pair(mk_numeral addr, mk_numeral v); + val mf = + list_mk_fupdate (mf_empty, List.map mk_fupdate_pair memmap); + in + mk_BVal_Mem (Bit64_tm, value_ty, mf) + end; + + fun build_env regmap mem = + let open stringSyntax bir_envSyntax; + fun go [] envf = envf + | go ((regname,v)::rs) envf = + go rs “\x. if x = ^(fromMLstring regname) then SOME (BVal_Imm (Imm64 ^(mk_wordi (v,64)))) else ^envf x” + val regenvf = go regmap “(\x.NONE): string -> bir_val_t option”; + val envf = “\x. if x = ^mem_string then SOME ^mem else ^regenvf x”; + in + mk_BEnv envf + end; + +in + +fun merge_machstate_into_bir_state st machstate = + let val (MACHSTATE (regmap, (wsz, defval, memmap))) = machstate; + + val mem = build_mem wsz defval (Redblackmap.listItems memmap); + val env = build_env (Redblackmap.listItems regmap) mem; + in + (rhs o concl) (EVAL “^st with <| bst_environ := ^env |>”) + end; + +fun merge_json_into_bir_state st = + merge_machstate_into_bir_state st o Json_to_machstate; + +(* first argument is the program (to initialise PC, etc.) *) +fun scamv_machstate_to_bir_state prog = + merge_machstate_into_bir_state “bir_state_init ^prog”; + +fun scamv_json_to_bir_state prog = scamv_machstate_to_bir_state prog o Json_to_machstate; + +end +end From 4046b79e034eb4ef3c9c3a638c29bcd741e775c0 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Tue, 27 Jul 2021 15:46:55 +0200 Subject: [PATCH 0066/1015] Fix --- src/tools/scamv/bir_machstate_importLib.sml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/tools/scamv/bir_machstate_importLib.sml b/src/tools/scamv/bir_machstate_importLib.sml index cbc93f043..30e6a015c 100644 --- a/src/tools/scamv/bir_machstate_importLib.sml +++ b/src/tools/scamv/bir_machstate_importLib.sml @@ -21,12 +21,14 @@ local mk_BVal_Mem (Bit64_tm, value_ty, mf) end; - fun build_env regmap mem = - let open stringSyntax bir_envSyntax; + fun build_env st regmap mem = + let open stringSyntax bir_envSyntax bir_programSyntax; + val (_,base_env,_) = dest_bir_state st; + val base_envf = dest_BEnv base_env; fun go [] envf = envf | go ((regname,v)::rs) envf = go rs “\x. if x = ^(fromMLstring regname) then SOME (BVal_Imm (Imm64 ^(mk_wordi (v,64)))) else ^envf x” - val regenvf = go regmap “(\x.NONE): string -> bir_val_t option”; + val regenvf = go regmap base_envf; val envf = “\x. if x = ^mem_string then SOME ^mem else ^regenvf x”; in mk_BEnv envf @@ -38,7 +40,7 @@ fun merge_machstate_into_bir_state st machstate = let val (MACHSTATE (regmap, (wsz, defval, memmap))) = machstate; val mem = build_mem wsz defval (Redblackmap.listItems memmap); - val env = build_env (Redblackmap.listItems regmap) mem; + val env = build_env st (Redblackmap.listItems regmap) mem; in (rhs o concl) (EVAL “^st with <| bst_environ := ^env |>”) end; From 8e9d7a082ef25c03846727c529afc27141d3eb82 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 28 Jul 2021 22:17:28 +0200 Subject: [PATCH 0067/1015] Add experiment set arguments --- src/tools/scamv/examples/expgenruns/micro2021_f7_c1_1.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_f7_c1_2.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_f7_c2_1.txt | 1 + src/tools/scamv/examples/expgenruns/micro2021_f7_c2_2.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_f7_c3.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_t1_c1_1.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_t1_c2_1.txt | 1 + src/tools/scamv/examples/expgenruns/micro2021_t1_c2_2.txt | 1 + src/tools/scamv/examples/expgenruns/micro2021_t1_c3_1.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_t1_c3_2.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_t1_c4_1.txt | 2 ++ src/tools/scamv/examples/expgenruns/micro2021_t1_c4_2.txt | 2 ++ 13 files changed, 23 insertions(+) create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_f7_c1_1.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_f7_c1_2.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_f7_c2_1.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_f7_c2_2.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_f7_c3.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c1_1.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c2_1.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c2_2.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c3_1.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c3_2.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c4_1.txt create mode 100644 src/tools/scamv/examples/expgenruns/micro2021_t1_c4_2.txt diff --git a/src/tools/scamv/examples/expgenruns/micro2021_f7_c1_1.txt b/src/tools/scamv/examples/expgenruns/micro2021_f7_c1_1.txt new file mode 100644 index 000000000..ad326eb1f --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_f7_c1_1.txt @@ -0,0 +1,2 @@ +-i 8 -t 1000 --generator qc --generator_param spectre_v1_mod2 --obs_model mem_address_pc --hw_obs_model hw_cache_tag_index -T + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_f7_c1_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_f7_c1_2.txt new file mode 100644 index 000000000..f115a2b12 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_f7_c1_2.txt @@ -0,0 +1,2 @@ +-i 8 -t 1000 --generator qc --generator_param spectre_v1_mod2 --obs_model cache_speculation --hw_obs_model hw_cache_tag_index -T + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_f7_c2_1.txt b/src/tools/scamv/examples/expgenruns/micro2021_f7_c2_1.txt new file mode 100644 index 000000000..bd1d2a34b --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_f7_c2_1.txt @@ -0,0 +1 @@ +-i 8 -t 1000 --generator qc --generator_param spectre_v1_mod2 --obs_model cache_speculation_first --hw_obs_model hw_cache_tag_index -T diff --git a/src/tools/scamv/examples/expgenruns/micro2021_f7_c2_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_f7_c2_2.txt new file mode 100644 index 000000000..dfb4c4ea3 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_f7_c2_2.txt @@ -0,0 +1,2 @@ +-t 40 -i 502 --obs_model cache_speculation_first --hw_obs_model hw_cache_tag_index -T --generator qc --generator_param xld_br_yld_mod1 -sz 2 + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_f7_c3.txt b/src/tools/scamv/examples/expgenruns/micro2021_f7_c3.txt new file mode 100644 index 000000000..5ec7c7259 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_f7_c3.txt @@ -0,0 +1,2 @@ +-t 100 -i 252 --generator qc --generator_param straightline_branch --obs_model cache_straightline --hw_obs_model hw_cache_tag_index + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_1.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_1.txt new file mode 100644 index 000000000..e036a3228 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_1.txt @@ -0,0 +1,2 @@ +-i 450 -t 40 --prog_size 5 --generator prefetch_strides --obs_model cache_tag_index_part --hw_obs_model hw_cache_tag_index_part + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt new file mode 100644 index 000000000..4801bd5c2 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt @@ -0,0 +1,2 @@ +--max_iter 420 --prog_size 5 --max_tests 40 --enumerate --generator prefetch_strides --obs_model cache_tag_index_part --hw_obs_model hw_cache_tag_index_part + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c2_1.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c2_1.txt new file mode 100644 index 000000000..e969cf590 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c2_1.txt @@ -0,0 +1 @@ +--max_iter 427 --prog_size 5 --max_tests 40 --generator prefetch_strides --obs_model cache_tag_index_part_page --hw_obs_model hw_cache_tag_index_part_page diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c2_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c2_2.txt new file mode 100644 index 000000000..c6a58b2b9 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c2_2.txt @@ -0,0 +1 @@ +--max_iter 427 --prog_size 5 --max_tests 40 --generator prefetch_strides --obs_model cache_tag_index_part_page --hw_obs_model hw_cache_tag_index_part_page --enumerate diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c3_1.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c3_1.txt new file mode 100644 index 000000000..dd5190530 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c3_1.txt @@ -0,0 +1,2 @@ +-i 760 -t 40 --generator qc --generator_param spectre --obs_model mem_address_pc --hw_obs_model hw_cache_tag_index -T + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c3_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c3_2.txt new file mode 100644 index 000000000..0be686c74 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c3_2.txt @@ -0,0 +1,2 @@ +-i 800 -t 40 --generator qc --generator_param spectre --obs_model cache_speculation --hw_obs_model hw_cache_tag_index -T + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c4_1.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c4_1.txt new file mode 100644 index 000000000..5fc4fa295 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c4_1.txt @@ -0,0 +1,2 @@ +-t 40 -i 502 --obs_model mem_address_pc --hw_obs_model hw_cache_tag_index -T --generator qc --generator_param xld_br_yld_mod1 -sz 2 + diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c4_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c4_2.txt new file mode 100644 index 000000000..8bc5c7799 --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c4_2.txt @@ -0,0 +1,2 @@ +-t 40 -i 502 --obs_model cache_speculation --hw_obs_model hw_cache_tag_index -T --generator qc --generator_param xld_br_yld_mod1 -sz 2 + From eec48ec1f125d33ca68de708aa01baa13e0984aa Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 30 Jul 2021 01:06:34 +0200 Subject: [PATCH 0068/1015] Fix arguments --- src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt b/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt index 4801bd5c2..256091b1f 100644 --- a/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt +++ b/src/tools/scamv/examples/expgenruns/micro2021_t1_c1_2.txt @@ -1,2 +1,3 @@ ---max_iter 420 --prog_size 5 --max_tests 40 --enumerate --generator prefetch_strides --obs_model cache_tag_index_part --hw_obs_model hw_cache_tag_index_part +-i 450 -t 40 --prog_size 5 --enumerate --generator prefetch_strides --obs_model cache_tag_index_part --hw_obs_model hw_cache_tag_index_part + From cc7bbbcbdbbfc20f705198bceeccb894c053a653 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 30 Jul 2021 17:26:40 +0200 Subject: [PATCH 0069/1015] Minor edit --- README.md | 1 - 1 file changed, 1 deletion(-) diff --git a/README.md b/README.md index ccbd52678..51be05d88 100644 --- a/README.md +++ b/README.md @@ -146,7 +146,6 @@ Notice that this sequence is just an example, and it is possible to selectively * Experimental passification transformation to SSA - `tools/scamv`: * Works for small programs - * Cannot handle certain cases, like memory dependent observations * Includes a selection of cache side channel models - `tools/wp`: * Proof-producing From a5c62c16216f17af887ac67ebfa583c8a3b5dbd9 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Fri, 30 Jul 2021 18:14:45 +0200 Subject: [PATCH 0070/1015] Updates --- src/tools/scamv/README.md | 28 +++++++++++--------- src/tools/scamv/examples/README.md | 4 +-- src/tools/scamv/examples/VM_setup.txt | 2 +- src/tools/scamv/examples/scripts/4-status.sh | 5 +++- 4 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/tools/scamv/README.md b/src/tools/scamv/README.md index 0649ef232..1ccfc3004 100644 --- a/src/tools/scamv/README.md +++ b/src/tools/scamv/README.md @@ -10,10 +10,10 @@ The possible options range from sizes for the desired experiment set, over gener The simple interface function `scamv_run_with_opts` of the same library may be used to create a configuration structure from command line arguments and initiate a SCAM-V run. This function uses the infrastructure from `scamv_configLib.sml` to parse the command line arguments from the environment. -Currently, a user of SCAM-V may simply run the script `examples/scamv.sh` from the command line with appropriate arguments. +Currently, a user of SCAM-V may simply run the script `examples/scamv.sh` (or `examples/scamv_buildheap.sh`) from the command line with appropriate arguments. There is the even more convenient option of using the SCAM-V process scripts in `examples/scripts`, which also provide support for parallelizing the test case generation and experiment running on real hardware. -These scripts introduce configuration files in `examples/expgenruns`. -See the documentation in [examples](https://github.com/kth-step/HolBA/tree/dev_scamv/src/tools/scamv/examples) for understanding these scripts and the process around this. +These scripts make use of configuration files in `examples/expgenruns`. +Please see the documentation in [examples](https://github.com/kth-step/HolBA/tree/dev_scamv/src/tools/scamv/examples) for understanding these scripts and the process around this. ## Components @@ -21,25 +21,27 @@ The main components of SCAM-V are the various program generators and observation See the following sections for more details on the program generators and observation models. The components of SCAM-V are: -- Program generators - `bir_prog_genLib`, `bir_gccLib` +- Program generators - directory `proggen` + - General core libraries - `proggen/bir_prog_genLib`, `proggen/bir_gccLib` - Random generators - - ARMv8 ISA syntax based - `bir_prog_gen_randLib` (`regExLib`) - - ARMv8 program slicing - `bir_prog_gen_sliceLib` + - ARMv8 ISA syntax based - `proggen/bir_prog_gen_randLib` (`proggen/regExLib`) + - ARMv8 program slicing - `proggen/bir_prog_gen_sliceLib` - Monadic generators - - Quickcheck - `qc_genLib` - - ARMv8 generator collection - `asm_genLib` - - ARMv8 generator "prefetch" - `armv8_prefetch_genLib` -- Observation modelling - - ARMv8 observation model collection - `bir_obs_modelTheory`, `bir_obs_modelLib` + - Quickcheck - `proggen/qc_genLib` + - ARMv8 generator collection - `proggen/asm_genLib` + - ARMv8 generator "prefetch" - `proggen/armv8_prefetch_genLib` +- Observation modelling - directory `obsmodel` + - ARMv8 observation model collection (`obsmodel/bir_obs_modelTheory`, `obsmodel/bir_obs_modelLib`) - SCAM-V main process chain and core libraries - SCAM-V driver - `bir_scamv_driverLib` - Symbolic execution engine - directory `symbexec`, `bir_conc_execLib` - Relation synthesis - `bir_rel_synthLib` +- Representation and persistence of experiments - directory `persistence` + - Experiment storage and loading - `persistenceLib` - Misc - SCAM-V shell scripts - directory `examples` - Configuration parser - `scamv_configLib` - - Experiment storage - `persistenceLib` - - Helper functions - `bir_scamv_helpersLib` + - Other libraries in this directory ## Program generators diff --git a/src/tools/scamv/examples/README.md b/src/tools/scamv/examples/README.md index 4affadc44..bc21a8bc7 100644 --- a/src/tools/scamv/examples/README.md +++ b/src/tools/scamv/examples/README.md @@ -36,7 +36,7 @@ The configuration and notes are in text files in `expgenruns`. The first line is Execute the following commands in order and in different shells and let them run in parallel to each other. 1. `./scripts/1-gen.sh cav_19-12-03 qc_previct5` 1. `./scripts/2-connect.sh rpi3` -1. `./scripts/3-run.sh arm8/exps2` +1. `./scripts/3-run.sh` See status of the run with `./scripts/4-status.sh`. @@ -44,5 +44,5 @@ Update HolBA and EmbExp-Box with `./scripts/5-update.sh`. ## Finish -After completing an experiment generation or run, don't forget to commit and push in `${HOLBA_DIR}/logs/EmbExp-Logs`. +After completing an experiment generation or run, don't forget to backup the database file `${HOLBA_DIR}/logs/EmbExp-Logs/data/logs.db`. diff --git a/src/tools/scamv/examples/VM_setup.txt b/src/tools/scamv/examples/VM_setup.txt index 6cbf949b8..bc3cab4ea 100644 --- a/src/tools/scamv/examples/VM_setup.txt +++ b/src/tools/scamv/examples/VM_setup.txt @@ -34,6 +34,6 @@ cd /home/holba/data/HolBA_scamv/src/tools/scamv/examples # open multiple shells in this directory and execute the following in order in each shell ./scripts/1-gen.sh test123 qc_xld ./scripts/2-connect.sh rpi3 -./scripts/3-run.sh arm8/exps2 +./scripts/3-run.sh ./scripts/4-status.sh diff --git a/src/tools/scamv/examples/scripts/4-status.sh b/src/tools/scamv/examples/scripts/4-status.sh index 4d7c177e6..31d548775 100755 --- a/src/tools/scamv/examples/scripts/4-status.sh +++ b/src/tools/scamv/examples/scripts/4-status.sh @@ -15,5 +15,8 @@ echo "============================" # in the logs directory, call the status script cd "${HOLBA_EMBEXP_LOGS}" -./scripts/status.py -ps ${EXTRA_OPTIONS} + +./scripts/db-eval.py + +./scripts/status.py ${EXTRA_OPTIONS} From 5dad79c7a0701ce90ebd270d6d05c1527f036082 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 2 Aug 2021 12:51:08 +0200 Subject: [PATCH 0071/1015] Add Observation model with type annotations (store not working yet) --- src/tools/scamv/obsmodel/bir_obs_modelLib.sig | 4 +- src/tools/scamv/obsmodel/bir_obs_modelLib.sml | 32 ++- .../scamv/obsmodel/bir_obs_modelScript.sml | 45 ++++ .../scamv/obsmodel/test-bir_obs_model.sml | 16 +- src/tools/scamv/obsmodel/testcases/prog_1.sml | 8 +- src/tools/scamv/obsmodel/testcases/prog_2.sml | 193 +++++++++++++++++- src/tools/scamv/obsmodel/testcases/prog_3.sml | 1 + src/tools/scamv/obsmodel/testcases/prog_4.sml | 1 + src/tools/scamv/obsmodel/testcases/prog_5.sml | 1 + src/tools/scamv/obsmodel/testcases/prog_6.sml | 1 + src/tools/scamv/obsmodel/testcases/prog_7.sml | 155 ++++++++++++++ 11 files changed, 439 insertions(+), 18 deletions(-) create mode 100644 src/tools/scamv/obsmodel/testcases/prog_7.sml diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sig b/src/tools/scamv/obsmodel/bir_obs_modelLib.sig index 83d557b5c..565824cc1 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sig +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sig @@ -3,13 +3,13 @@ signature bir_obs_modelLib = include Abbrev; val get_obs_model : string -> { id : string, - obs_hol_type : term, + obs_hol_type : hol_type, add_obs : term -> term -> term } end signature OBS_MODEL = sig - val obs_hol_type : Abbrev.term + val obs_hol_type : Abbrev.hol_type (* takes boundary for mremory load and store addresses (min and max) *) (* In HOL: (word64 # word64) -> 'a bir_program_t -> obs_hol_type bir_program_t *) diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml index 5016ab0f4..894948213 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml @@ -14,49 +14,55 @@ in structure bir_pc_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_pc ^mb ^t``)); end structure bir_arm8_mem_addr_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_mem_addr_armv8 ^mb ^t``)); end structure bir_arm8_mem_addr_pc_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_mem_addr_pc_armv8 ^mb ^t``)); end +structure bir_arm8_mem_addr_pc_lspc_model : OBS_MODEL = +struct +val obs_hol_type = ``:load_store_pc_t``; +fun add_obs mb t = rand (concl (EVAL ``add_obs_mem_addr_pc_lspc_armv8 ^mb ^t``)); +end + structure bir_arm8_cache_line_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_cache_line_tag_index_armv8 ^mb ^t``)); end structure bir_arm8_cache_line_tag_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_cache_line_tag_armv8 ^mb ^t``)); end structure bir_arm8_cache_line_index_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_cache_line_index_armv8 ^mb ^t``)); end structure bir_arm8_cache_line_subset_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_cache_line_subset_armv8 ^mb ^t``)); end structure bir_arm8_cache_line_subset_page_model : OBS_MODEL = struct -val obs_hol_type = ``bir_val_t``; +val obs_hol_type = ``:bir_val_t``; fun add_obs mb t = rand (concl (EVAL ``add_obs_cache_line_subset_page_armv8 ^mb ^t``)); end @@ -309,7 +315,7 @@ in structure bir_arm8_cache_speculation_model : OBS_MODEL = struct - val obs_hol_type = ``bir_val_t``; + val obs_hol_type = ``:bir_val_t``; val pipeline_depth = 3; fun add_obs mb t = branch_instrumentation obs_all_refined (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; @@ -317,7 +323,7 @@ in structure bir_arm8_cache_speculation_first_model : OBS_MODEL = struct - val obs_hol_type = ``bir_val_t``; + val obs_hol_type = ``:bir_val_t``; val pipeline_depth = 3; fun add_obs mb t = branch_instrumentation obs_all_refined_but_first (bir_arm8_mem_addr_pc_model.add_obs mb t) pipeline_depth; @@ -325,7 +331,7 @@ in structure bir_arm8_cache_straight_line_model : OBS_MODEL = struct - val obs_hol_type = ``bir_val_t``; + val obs_hol_type = ``:bir_val_t``; val pipeline_depth = 3; fun add_obs mb t = let val obs_term = bir_arm8_mem_addr_pc_model.add_obs mb t; @@ -343,6 +349,8 @@ fun get_obs_model id = val obs_hol_type = if id = "mem_address_pc" then bir_arm8_mem_addr_pc_model.obs_hol_type + else if id = "mem_address_pc_lspc" then + bir_arm8_mem_addr_pc_lspc_model.obs_hol_type else if id = "cache_tag_index" then bir_arm8_cache_line_model.obs_hol_type else if id = "cache_tag_only" then @@ -365,6 +373,8 @@ fun get_obs_model id = val add_obs = if id = "mem_address_pc" then bir_arm8_mem_addr_pc_model.add_obs + else if id = "mem_address_pc_lspc" then + bir_arm8_mem_addr_pc_lspc_model.add_obs else if id = "cache_tag_index" then bir_arm8_cache_line_model.add_obs else if id = "cache_tag_only" then diff --git a/src/tools/scamv/obsmodel/bir_obs_modelScript.sml b/src/tools/scamv/obsmodel/bir_obs_modelScript.sml index e2d840cb1..952188f21 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelScript.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelScript.sml @@ -5,6 +5,23 @@ open wordsSyntax; val _ = new_theory "bir_obs_model"; +val _ = Datatype `load_store_pc_t = + LSPC_Load bir_val_t + | LSPC_Store bir_val_t + | LSPC_PC bir_val_t`; + +val gen_LSPC_Load_def = Define ` + gen_LSPC_Load [x] = LSPC_Load x +`; + +val gen_LSPC_Store_def = Define ` + gen_LSPC_Store [x] = LSPC_Store x +`; + +val gen_LSPC_PC_def = Define ` + gen_LSPC_PC [x] = LSPC_PC x +`; + val map_obs_prog_def = Define ` map_obs_prog f (BirProgram xs) = BirProgram (MAP f xs) `; @@ -79,6 +96,13 @@ val observe_label_def = Define ` [BExp_Const addr] HD `; +val observe_label_pc_def = Define ` + observe_label_pc (BL_Address addr) = + BStmt_Observe 0 + (BExp_Const (Imm1 1w)) + [BExp_Const addr] + gen_LSPC_PC +`; val add_obs_pc_block_def = Define` add_obs_pc_block block = @@ -86,6 +110,12 @@ val add_obs_pc_block_def = Define` observe_label (block.bb_label) :: block.bb_statements `; +val add_obs_pc_block_pc_def = Define` + add_obs_pc_block_pc block = + block with bb_statements := + observe_label_pc (block.bb_label) :: block.bb_statements +`; + val add_obs_pc_def = Define` add_obs_pc p = map_obs_prog add_obs_pc_block p `; @@ -99,6 +129,13 @@ val observe_mem_addr_def = Define` [e] HD `; +val observe_mem_addr_ls_def = Define` + observe_mem_addr_ls e = + BStmt_Observe 0 + (BExp_Const (Imm1 1w)) + [e] + gen_LSPC_Load +`; val add_obs_mem_addr_armv8_def = Define` add_obs_mem_addr_armv8 mem_bounds p = @@ -114,6 +151,14 @@ val add_obs_mem_addr_pc_armv8_def = Define` `; +(* observe whole memory address and pc (lspc type construction annototation) *) +(* ============================================================================== *) +val add_obs_mem_addr_pc_lspc_armv8_def = Define` + add_obs_mem_addr_pc_lspc_armv8 mem_bounds p = + map_obs_prog (add_obs_pc_block_pc o (add_obs_constr_mem_block mem_bounds observe_mem_addr_ls)) p +`; + + (* generic helper for augmentation of transient execution (prepend observation to specific block) *) (* ============================================================================== *) diff --git a/src/tools/scamv/obsmodel/test-bir_obs_model.sml b/src/tools/scamv/obsmodel/test-bir_obs_model.sml index d30ff671f..4df61b349 100644 --- a/src/tools/scamv/obsmodel/test-bir_obs_model.sml +++ b/src/tools/scamv/obsmodel/test-bir_obs_model.sml @@ -34,6 +34,7 @@ val _ = QUse.use "testcases/prog_3.sml"; val _ = QUse.use "testcases/prog_4.sml"; val _ = QUse.use "testcases/prog_5.sml"; val _ = QUse.use "testcases/prog_6.sml"; +val _ = QUse.use "testcases/prog_7.sml"; @@ -45,20 +46,27 @@ val test_cases = prog_3_test, prog_4_test, prog_5_test, - prog_6_test] + prog_6_test, + prog_7_test] (* =========================== run and compare test cases ============================ *) val _ = print "\n\n"; +fun prog_obs_inst prog obs_type = + inst [Type`:'obs_type` |-> obs_type] prog; + (* val (name, prog, expected) = hd test_cases; +val (name, prog, expected) = prog_2_test; + val (name, prog, expected) = prog_5_test; val m = "cache_speculation_first"; -(#add_obs (get_obs_model m)) mem_bounds prog +val m = "mem_address_pc_lspc"; +(#add_obs (get_obs_model m)) mem_bounds (prog_obs_inst prog (#obs_hol_type (get_obs_model m))) *) fun run_test_case (name, prog, expected) = let @@ -66,9 +74,10 @@ fun run_test_case (name, prog, expected) = fun fold_obs_add ((m, p), l) = if identical p ``F`` then (print ("!!! no expected output for '" ^ m ^ "' !!!\n"); l) - else (((#add_obs (get_obs_model m)) mem_bounds prog, p)::l); + else (((#add_obs (get_obs_model m)) mem_bounds (prog_obs_inst prog (#obs_hol_type (get_obs_model m))), p)::l); val (expected_mem_address_pc, + expected_mem_address_pc_lspc, expected_cache_tag_index, expected_cache_tag_only, expected_cache_index_only, @@ -79,6 +88,7 @@ fun run_test_case (name, prog, expected) = val progs_list_raw = [("mem_address_pc", expected_mem_address_pc), + ("mem_address_pc_lspc", expected_mem_address_pc_lspc), ("cache_tag_index", expected_cache_tag_index), ("cache_tag_only", expected_cache_tag_only), ("cache_index_only", expected_cache_index_only), diff --git a/src/tools/scamv/obsmodel/testcases/prog_1.sml b/src/tools/scamv/obsmodel/testcases/prog_1.sml index d1b59f974..a868aadd0 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_1.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_1.sml @@ -2,7 +2,7 @@ val prog_1 = `` BirProgram [] -:bir_val_t bir_program_t +:'obs_type bir_program_t ``; val prog_1_mem_address_pc = `` @@ -10,6 +10,11 @@ BirProgram [] :bir_val_t bir_program_t ``; +val prog_1_mem_address_pc_lspc = `` +BirProgram [] +:load_store_pc_t bir_program_t +``; + val prog_1_cache_tag_index = `` BirProgram [] :bir_val_t bir_program_t @@ -46,6 +51,7 @@ F val prog_1_test = ("prog_1 - empty program", prog_1, (prog_1_mem_address_pc, + prog_1_mem_address_pc_lspc, prog_1_cache_tag_index, prog_1_cache_tag_only, prog_1_cache_index_only, diff --git a/src/tools/scamv/obsmodel/testcases/prog_2.sml b/src/tools/scamv/obsmodel/testcases/prog_2.sml index 812846cee..ac695c29d 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_2.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_2.sml @@ -93,7 +93,7 @@ BirProgram bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 28w)))|>; <|bb_label := BL_Address (Imm64 28w); bb_statements := []; bb_last_statement := BStmt_Halt (BExp_Const (Imm32 0w))|>] -:bir_val_t bir_program_t +:'obs_type bir_program_t ``; val prog_2_mem_address_pc = `` @@ -259,6 +259,196 @@ BirProgram :bir_val_t bir_program_t ``; +val prog_2_mem_address_pc_lspc = `` +BirProgram + [<|bb_label := BL_Address (Imm64 (0w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (0w :word64))] gen_LSPC_PC; + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + load_store_pc_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))] gen_LSPC_Load; + (BStmt_Assign (BVar "R26" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + BEnd_LittleEndian Bit64) :load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (4w :word64))))|>; + <|bb_label := BL_Address (Imm64 (4w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (4w :word64))] gen_LSPC_PC; + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "R17" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R17" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R17" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + load_store_pc_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R17" (BType_Imm Bit64))] gen_LSPC_Load; + (BStmt_Assign (BVar "R15" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (8w :word64))))|>; + <|bb_label := BL_Address (Imm64 (8w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (8w :word64))] gen_LSPC_PC; + (BStmt_Assign (BVar "ProcState_C" (BType_Imm Bit1)) + (BExp_BinPred BIExp_LessOrEqual + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_N" (BType_Imm Bit1)) + (BExp_BinPred BIExp_SignedLessThan + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "R14" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_V" (BType_Imm Bit1)) + (BExp_BinPred BIExp_Equal + (BExp_BinPred BIExp_SignedLessThan + (BExp_BinExp BIExp_Minus + (BExp_Den (BVar "R14" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0w :word64)))) + (BExp_BinPred BIExp_SignedLessOrEqual + (BExp_Den (BVar "R15" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64))))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assign (BVar "ProcState_Z" (BType_Imm Bit1)) + (BExp_BinPred BIExp_Equal + (BExp_Den (BVar "R14" (BType_Imm Bit64))) + (BExp_Den (BVar "R15" (BType_Imm Bit64)))) : + load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (12w :word64))))|>; + <|bb_label := BL_Address (Imm64 (12w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (12w :word64))] gen_LSPC_PC]; + bb_last_statement := + BStmt_CJmp (BExp_Den (BVar "ProcState_Z" (BType_Imm Bit1))) + (BLE_Label (BL_Address (Imm64 (24w :word64)))) + (BLE_Label (BL_Address (Imm64 (16w :word64))))|>; + <|bb_label := BL_Address (Imm64 (16w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (16w :word64))] gen_LSPC_PC; + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (4w :word64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + load_store_pc_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))] gen_LSPC_Load; + (BStmt_Assign (BVar "R10" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R26" (BType_Imm Bit64))) + (BExp_Const (Imm64 (76w :word64)))) BEnd_LittleEndian + Bit64) :load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (20w :word64))))|>; + <|bb_label := BL_Address (Imm64 (20w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (20w :word64))] gen_LSPC_PC]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (28w :word64))))|>; + <|bb_label := BL_Address (Imm64 (24w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (24w :word64))] gen_LSPC_PC; + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "R9" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R9" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R9" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + load_store_pc_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R9" (BType_Imm Bit64))] gen_LSPC_Load; + (BStmt_Assign (BVar "R14" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R9" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (28w :word64))))|>; + <|bb_label := BL_Address (Imm64 (28w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (28w :word64))] gen_LSPC_PC]; + bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] +:load_store_pc_t bir_program_t +``; + val prog_2_cache_tag_index = `` BirProgram [<|bb_label := BL_Address (Imm64 0w); @@ -1382,6 +1572,7 @@ F val prog_2_test = ("prog_2 - branch and merge", prog_2, (prog_2_mem_address_pc, + prog_2_mem_address_pc_lspc, prog_2_cache_tag_index, prog_2_cache_tag_only, prog_2_cache_index_only, diff --git a/src/tools/scamv/obsmodel/testcases/prog_3.sml b/src/tools/scamv/obsmodel/testcases/prog_3.sml index cbe00de59..0e91c5453 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_3.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_3.sml @@ -130,6 +130,7 @@ F val prog_3_test = ("prog_3 - spectre_v1", prog_3, (prog_3_mem_address_pc, + ``F``, prog_3_cache_tag_index, prog_3_cache_tag_only, prog_3_cache_index_only, diff --git a/src/tools/scamv/obsmodel/testcases/prog_4.sml b/src/tools/scamv/obsmodel/testcases/prog_4.sml index 8517302ce..1ea153464 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_4.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_4.sml @@ -132,6 +132,7 @@ F val prog_4_test = ("prog_4 - xld_br_yld", prog_4, (prog_4_mem_address_pc, + ``F``, prog_4_cache_tag_index, prog_4_cache_tag_only, prog_4_cache_index_only, diff --git a/src/tools/scamv/obsmodel/testcases/prog_5.sml b/src/tools/scamv/obsmodel/testcases/prog_5.sml index 1e2a4e78b..bcf58e7d9 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_5.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_5.sml @@ -405,6 +405,7 @@ BirProgram val prog_5_test = ("prog_5 - spectre_v1_mod1", prog_5, (prog_5_mem_address_pc, + ``F``, prog_5_cache_tag_index, prog_5_cache_tag_only, prog_5_cache_index_only, diff --git a/src/tools/scamv/obsmodel/testcases/prog_6.sml b/src/tools/scamv/obsmodel/testcases/prog_6.sml index 6d4ec3374..ceb018659 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_6.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_6.sml @@ -317,6 +317,7 @@ F val prog_6_test = ("prog_6 - xld_br_yld_mod1", prog_6, (prog_6_mem_address_pc, + ``F``, prog_6_cache_tag_index, prog_6_cache_tag_only, prog_6_cache_index_only, diff --git a/src/tools/scamv/obsmodel/testcases/prog_7.sml b/src/tools/scamv/obsmodel/testcases/prog_7.sml new file mode 100644 index 000000000..100455df7 --- /dev/null +++ b/src/tools/scamv/obsmodel/testcases/prog_7.sml @@ -0,0 +1,155 @@ +(* ========================= prog_7 - test LSPC observations =========================== *) + +val prog_7 = `` +BirProgram + [<|bb_label := + BL_Address_HC (Imm64 0w) "F87869DA (ldr x26, [x14, x24])"; + bb_statements := + [BStmt_Assert + (BExp_Aligned Bit64 3 + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64))))); + BStmt_Assign (BVar "R26" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + BEnd_LittleEndian Bit64)]; + bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 4w)))|>; + <|bb_label := BL_Address_HC (Imm64 4w) "F940022F (ldr x15, [x17])"; + bb_statements := + [BStmt_Assert + (BExp_Aligned Bit64 3 + (BExp_Den (BVar "R17" (BType_Imm Bit64)))); + BStmt_Assign (BVar "R15" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64)]; + bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 8w)))|>; + <|bb_label := BL_Address (Imm64 8w); bb_statements := []; + bb_last_statement := BStmt_Halt (BExp_Const (Imm32 0w))|>] +:'obs_type bir_program_t +``; + +val prog_7_mem_address_pc = `` +F +``; + +val prog_7_mem_address_pc_lspc = `` +BirProgram + [<|bb_label := BL_Address (Imm64 (0w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (0w :word64))] gen_LSPC_PC; + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64))))) + (BExp_BinPred BIExp_LessThan + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + load_store_pc_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_BinExp BIExp_Plus (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))] gen_LSPC_Load; + (BStmt_Assign (BVar "R26" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_BinExp BIExp_Plus + (BExp_Den (BVar "R24" (BType_Imm Bit64))) + (BExp_Den (BVar "R14" (BType_Imm Bit64)))) BEnd_LittleEndian + Bit64) :load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (4w :word64))))|>; + <|bb_label := BL_Address (Imm64 (4w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (4w :word64))] gen_LSPC_PC; + (BStmt_Assert + (BExp_BinPred BIExp_Equal + (BExp_BinExp BIExp_And + (BExp_Den (BVar "R17" (BType_Imm Bit64))) + (BExp_Const (Imm64 (7w :word64)))) + (BExp_Const (Imm64 (0w :word64)))) : + load_store_pc_t bir_stmt_basic_t); + (BStmt_Assert + (BExp_BinExp BIExp_And + (BExp_BinPred BIExp_LessOrEqual + (BExp_Const (Imm64 (0xFFCC0000w :word64))) + (BExp_Den (BVar "R17" (BType_Imm Bit64)))) + (BExp_BinPred BIExp_LessThan + (BExp_Den (BVar "R17" (BType_Imm Bit64))) + (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : + load_store_pc_t bir_stmt_basic_t); + BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Den (BVar "R17" (BType_Imm Bit64))] gen_LSPC_Load; + (BStmt_Assign (BVar "R15" (BType_Imm Bit64)) + (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian + Bit64) :load_store_pc_t bir_stmt_basic_t)]; + bb_last_statement := + BStmt_Jmp (BLE_Label (BL_Address (Imm64 (8w :word64))))|>; + <|bb_label := BL_Address (Imm64 (8w :word64)); + bb_statements := + [BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) + [BExp_Const (Imm64 (8w :word64))] gen_LSPC_PC]; + bb_last_statement := BStmt_Halt (BExp_Const (Imm32 (0w :word32)))|>] +:load_store_pc_t bir_program_t +``; + + +val prog_7_cache_tag_index = `` +F +``; + +val prog_7_cache_tag_only = `` +F +``; + +val prog_7_cache_index_only = `` +F +``; + +val prog_7_cache_tag_index_part = `` +F +``; + +val prog_7_cache_tag_index_part_page = `` +F +``; + +val prog_7_cache_speculation = `` +F +``; + +val prog_7_cache_speculation_first = `` +F +``; + +val prog_7_test = + ("prog_7 - LSPC test", prog_7, + (prog_7_mem_address_pc, + prog_7_mem_address_pc_lspc, + prog_7_cache_tag_index, + prog_7_cache_tag_only, + prog_7_cache_index_only, + prog_7_cache_tag_index_part, + prog_7_cache_tag_index_part_page, + prog_7_cache_speculation, + prog_7_cache_speculation_first) + ); + From f408a44a7764ab90526645476c6264c2f3af6249 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 2 Aug 2021 13:25:17 +0200 Subject: [PATCH 0072/1015] Fix stores --- .../scamv/obsmodel/bir_obs_modelScript.sml | 46 +++++++++++++------ src/tools/scamv/obsmodel/testcases/prog_7.sml | 10 ++-- 2 files changed, 37 insertions(+), 19 deletions(-) diff --git a/src/tools/scamv/obsmodel/bir_obs_modelScript.sml b/src/tools/scamv/obsmodel/bir_obs_modelScript.sml index 952188f21..dfb34192a 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelScript.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelScript.sml @@ -26,6 +26,11 @@ val map_obs_prog_def = Define ` map_obs_prog f (BirProgram xs) = BirProgram (MAP f xs) `; + +val _ = Datatype `select_mem_t = + select_mem_LD bir_exp_t + | select_mem_ST bir_exp_t`; + val select_mem_def = Define` select_mem exp = (case exp of @@ -35,12 +40,16 @@ select_mem exp = | BExp_BinPred bp e1 e2 => select_mem e1 ++ select_mem e2 | BExp_MemEq e1 e2 => select_mem e1 ++ select_mem e2 | BExp_IfThenElse e1 e2 e3 => select_mem e1 ++ select_mem e2 ++ select_mem e3 - | BExp_Load e1 e2 a b => e2 :: (select_mem e1 ++ select_mem e2) - | BExp_Store e1 e2 a e3 => e2 :: (select_mem e1 ++ select_mem e2 ++ select_mem e3) + | BExp_Load e1 e2 a b => (select_mem_LD e2) :: (select_mem e1 ++ select_mem e2) + | BExp_Store e1 e2 a e3 => (select_mem_ST e2) :: (select_mem e1 ++ select_mem e2 ++ select_mem e3) | _ => []) +`; +val select_mem_flatten_def = Define` +select_mem_flatten x = case x of select_mem_LD e => e | select_mem_ST e => e `; + val constrain_mem_def = Define` constrain_mem (mem_min, mem_max) e = BStmt_Assert @@ -49,17 +58,21 @@ constrain_mem (mem_min, mem_max) e = (BExp_BinPred BIExp_LessThan (e) (BExp_Const (Imm64 mem_max)))) `; -val add_obs_constr_mem_stmts_def = Define ` -(add_obs_constr_mem_stmts mem_bounds obs_fun [] = []) /\ -(add_obs_constr_mem_stmts mem_bounds obs_fun (x :: xs) = +val add_obs_constr_mem_stmts_ls_def = Define ` +(add_obs_constr_mem_stmts_ls mem_bounds obs_fun_ld obs_fun_st [] = []) /\ +(add_obs_constr_mem_stmts_ls mem_bounds obs_fun_ld obs_fun_st (x :: xs) = case x of BStmt_Assign v e => (case select_mem e of - [] => x :: add_obs_constr_mem_stmts mem_bounds obs_fun xs - | lds => (APPEND (MAP (constrain_mem mem_bounds) lds) + [] => x :: add_obs_constr_mem_stmts_ls mem_bounds obs_fun_ld obs_fun_st xs + | lds => (APPEND (MAP (constrain_mem mem_bounds) (MAP select_mem_flatten lds)) (* TODO: (Andreas:) Can it be that there is a bug here with the order, first xs, and then x? *) - (APPEND (APPEND (MAP obs_fun lds) (add_obs_constr_mem_stmts mem_bounds obs_fun xs)) [x]))) - | _ => x :: add_obs_constr_mem_stmts mem_bounds obs_fun xs) + (APPEND (APPEND (MAP (\x. case x of select_mem_LD e => obs_fun_ld e | select_mem_ST e => obs_fun_st e) lds) (add_obs_constr_mem_stmts_ls mem_bounds obs_fun_ld obs_fun_st xs)) [x]))) + | _ => x :: add_obs_constr_mem_stmts_ls mem_bounds obs_fun_ld obs_fun_st xs) +`; + +val add_obs_constr_mem_stmts_def = Define ` + add_obs_constr_mem_stmts mem_bounds obs_fun = add_obs_constr_mem_stmts_ls mem_bounds obs_fun obs_fun `; val add_obs_constr_mem_block_def = Define` @@ -67,6 +80,11 @@ val add_obs_constr_mem_block_def = Define` block with bb_statements := add_obs_constr_mem_stmts mem_bounds obs_fun block.bb_statements `; +val add_obs_constr_mem_block_ls_def = Define` + add_obs_constr_mem_block_ls mem_bounds obs_fun_ld obs_fun_st block = + block with bb_statements := add_obs_constr_mem_stmts_ls mem_bounds obs_fun_ld obs_fun_st block.bb_statements +`; + val map_end_prog_def = Define‘ map_end_prog f [] = [] @@ -129,12 +147,12 @@ val observe_mem_addr_def = Define` [e] HD `; -val observe_mem_addr_ls_def = Define` - observe_mem_addr_ls e = +val observe_gen_def = Define` + observe_gen gen_fun e = BStmt_Observe 0 (BExp_Const (Imm1 1w)) [e] - gen_LSPC_Load + gen_fun `; val add_obs_mem_addr_armv8_def = Define` @@ -155,7 +173,7 @@ val add_obs_mem_addr_pc_armv8_def = Define` (* ============================================================================== *) val add_obs_mem_addr_pc_lspc_armv8_def = Define` add_obs_mem_addr_pc_lspc_armv8 mem_bounds p = - map_obs_prog (add_obs_pc_block_pc o (add_obs_constr_mem_block mem_bounds observe_mem_addr_ls)) p + map_obs_prog (add_obs_pc_block_pc o (add_obs_constr_mem_block_ls mem_bounds (observe_gen gen_LSPC_Load) (observe_gen gen_LSPC_Store))) p `; @@ -294,7 +312,7 @@ val add_obs_stmts_subset_and_line_def = Define ` (add_obs_constr_mem_stmts_subset_and_line mem_bounds (x :: xs) = case x of BStmt_Assign v e => - (case select_mem e of + (case MAP select_mem_flatten (select_mem e) of [] => x :: add_obs_stmts_subset mem_bounds xs | lds => (APPEND (MAP (constrain_mem mem_bounds) lds) (x :: (APPEND (MAP observe_mem_subset lds) diff --git a/src/tools/scamv/obsmodel/testcases/prog_7.sml b/src/tools/scamv/obsmodel/testcases/prog_7.sml index 100455df7..7dae6c0ec 100644 --- a/src/tools/scamv/obsmodel/testcases/prog_7.sml +++ b/src/tools/scamv/obsmodel/testcases/prog_7.sml @@ -23,9 +23,9 @@ BirProgram (BExp_Aligned Bit64 3 (BExp_Den (BVar "R17" (BType_Imm Bit64)))); BStmt_Assign (BVar "R15" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Store (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian - Bit64)]; + (BExp_Const (Imm32 (100w :word32))))]; bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 8w)))|>; <|bb_label := BL_Address (Imm64 8w); bb_statements := []; bb_last_statement := BStmt_Halt (BExp_Const (Imm32 0w))|>] @@ -96,11 +96,11 @@ BirProgram (BExp_Const (Imm64 (0xFFCCFF80w :word64))))) : load_store_pc_t bir_stmt_basic_t); BStmt_Observe (0 :num) (BExp_Const (Imm1 (1w :word1))) - [BExp_Den (BVar "R17" (BType_Imm Bit64))] gen_LSPC_Load; + [BExp_Den (BVar "R17" (BType_Imm Bit64))] gen_LSPC_Store; (BStmt_Assign (BVar "R15" (BType_Imm Bit64)) - (BExp_Load (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) + (BExp_Store (BExp_Den (BVar "MEM" (BType_Mem Bit64 Bit8))) (BExp_Den (BVar "R17" (BType_Imm Bit64))) BEnd_LittleEndian - Bit64) :load_store_pc_t bir_stmt_basic_t)]; + (BExp_Const (Imm32 (100w :word32)))) :load_store_pc_t bir_stmt_basic_t)]; bb_last_statement := BStmt_Jmp (BLE_Label (BL_Address (Imm64 (8w :word64))))|>; <|bb_label := BL_Address (Imm64 (8w :word64)); From 826514444acc7a22090e5c287405cf2506fd0172 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 2 Aug 2021 13:48:15 +0200 Subject: [PATCH 0073/1015] Generate generic 'obs_type bir programs --- src/tools/scamv/bir_scamv_driverLib.sml | 6 ++++-- src/tools/scamv/obsmodel/bir_obs_modelLib.sig | 2 ++ src/tools/scamv/obsmodel/bir_obs_modelLib.sml | 5 +++++ src/tools/scamv/obsmodel/test-bir_obs_model.sml | 3 +-- src/tools/scamv/proggen/bir_prog_genLib.sml | 2 +- 5 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index 1644d8152..bfd3ee87f 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -166,7 +166,9 @@ fun scamv_set_prog_state prog = fun scamv_phase_add_obs () = let val _ = printv 1 "Adding obs\n"; - val add_obs = #add_obs (get_obs_model (!current_obs_model_id)); + val obs_model = get_obs_model (!current_obs_model_id); + val add_obs = #add_obs obs_model; + val proginst_fun = proginst_fun_gen (#obs_hol_type obs_model); val mem_bounds = let val (mem_base, mem_len) = embexp_params_memory; @@ -176,7 +178,7 @@ let (mk_wordi (embexp_params_cacheable mem_base, 64), mk_wordi (embexp_params_cacheable mem_end, 64)) end; - val lifted_prog_w_obs = add_obs mem_bounds (valOf (!current_prog)); + val lifted_prog_w_obs = add_obs mem_bounds (proginst_fun (valOf (!current_prog))); val _ = printv 1 "Obs added\n"; val _ = current_prog_w_obs := SOME lifted_prog_w_obs; val _ = min_verb 3 (fn () => print_term lifted_prog_w_obs); diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sig b/src/tools/scamv/obsmodel/bir_obs_modelLib.sig index 565824cc1..3bf05b182 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sig +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sig @@ -2,6 +2,8 @@ signature bir_obs_modelLib = sig include Abbrev; + val proginst_fun_gen : hol_type -> term -> term + val get_obs_model : string -> { id : string, obs_hol_type : hol_type, add_obs : term -> term -> term } diff --git a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml index 894948213..1e5626ec9 100644 --- a/src/tools/scamv/obsmodel/bir_obs_modelLib.sml +++ b/src/tools/scamv/obsmodel/bir_obs_modelLib.sml @@ -12,6 +12,11 @@ local open bir_obs_modelTheory; in + +fun proginst_fun_gen obs_type prog = + inst [Type`:'obs_type` |-> obs_type] prog; + + structure bir_pc_model : OBS_MODEL = struct val obs_hol_type = ``:bir_val_t``; diff --git a/src/tools/scamv/obsmodel/test-bir_obs_model.sml b/src/tools/scamv/obsmodel/test-bir_obs_model.sml index 4df61b349..b7087a741 100644 --- a/src/tools/scamv/obsmodel/test-bir_obs_model.sml +++ b/src/tools/scamv/obsmodel/test-bir_obs_model.sml @@ -54,8 +54,7 @@ val test_cases = val _ = print "\n\n"; -fun prog_obs_inst prog obs_type = - inst [Type`:'obs_type` |-> obs_type] prog; +fun prog_obs_inst prog obs_type = proginst_fun_gen obs_type prog; (* val (name, prog, expected) = hd test_cases; diff --git a/src/tools/scamv/proggen/bir_prog_genLib.sml b/src/tools/scamv/proggen/bir_prog_genLib.sml index 6fa8b1373..65c5c6d1c 100644 --- a/src/tools/scamv/proggen/bir_prog_genLib.sml +++ b/src/tools/scamv/proggen/bir_prog_genLib.sml @@ -63,7 +63,7 @@ struct val (thm_prog, errors) = bmil_bir_lift_prog_gen prog_range sections; val lifted_prog = (snd o dest_comb o concl) thm_prog; val lifted_prog_typed = - inst [Type`:'observation_type` |-> Type`:bir_val_t`] + inst [Type`:'observation_type` |-> Type`:'obs_type`] lifted_prog; in lifted_prog_typed From a5cc93547254c7219ff10ea7743ff9a80a755ded Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 2 Aug 2021 13:49:29 +0200 Subject: [PATCH 0074/1015] Enable experiments with the new observation model --- src/tools/scamv/bir_scamv_driverLib.sml | 2 ++ src/tools/scamv/examples/expgenruns/test_lspc.txt | 2 ++ src/tools/scamv/scamv_configLib.sig | 1 + src/tools/scamv/scamv_configLib.sml | 4 +++- 4 files changed, 8 insertions(+), 1 deletion(-) create mode 100644 src/tools/scamv/examples/expgenruns/test_lspc.txt diff --git a/src/tools/scamv/bir_scamv_driverLib.sml b/src/tools/scamv/bir_scamv_driverLib.sml index bfd3ee87f..02c941f45 100644 --- a/src/tools/scamv/bir_scamv_driverLib.sml +++ b/src/tools/scamv/bir_scamv_driverLib.sml @@ -493,6 +493,8 @@ fun match_obs_model obs_model = case obs_model of mem_address_pc => "mem_address_pc" + | mem_address_pc_lspc => + "mem_address_pc_lspc" | cache_tag_index => "cache_tag_index" | cache_tag_only => diff --git a/src/tools/scamv/examples/expgenruns/test_lspc.txt b/src/tools/scamv/examples/expgenruns/test_lspc.txt new file mode 100644 index 000000000..8855efc7d --- /dev/null +++ b/src/tools/scamv/examples/expgenruns/test_lspc.txt @@ -0,0 +1,2 @@ +-t 40 -i 502 --obs_model mem_address_pc_lspc --hw_obs_model hw_cache_tag_index -T --generator qc --generator_param xld_br_yld_mod1 -sz 2 + diff --git a/src/tools/scamv/scamv_configLib.sig b/src/tools/scamv/scamv_configLib.sig index 2c7ce679b..72b3de784 100644 --- a/src/tools/scamv/scamv_configLib.sig +++ b/src/tools/scamv/scamv_configLib.sig @@ -9,6 +9,7 @@ sig | from_list datatype obs_model = mem_address_pc + | mem_address_pc_lspc | cache_tag_index | cache_tag_only | cache_index_only diff --git a/src/tools/scamv/scamv_configLib.sml b/src/tools/scamv/scamv_configLib.sml index 55d99ed0c..16c809df9 100644 --- a/src/tools/scamv/scamv_configLib.sml +++ b/src/tools/scamv/scamv_configLib.sml @@ -20,6 +20,7 @@ datatype gen_type = gen_rand | from_list datatype obs_model = mem_address_pc + | mem_address_pc_lspc | cache_tag_index | cache_tag_only | cache_index_only @@ -81,6 +82,7 @@ fun gen_type_fromString gt = fun obs_model_fromString om = case om of "mem_address_pc" => SOME mem_address_pc + | "mem_address_pc_lspc" => SOME mem_address_pc_lspc | "cache_tag_index" => SOME cache_tag_index | "cache_tag_only" => SOME cache_tag_only | "cache_index_only" => SOME cache_index_only @@ -438,7 +440,7 @@ fun print_scamv_opt_usage () = print "Scam-V Usage:\n\n"; List.map print_entry opt_table; print ("\ngenerator arg should be one of: rand, prefetch_strides, qc, slice, file, list\n"); - print ("\nobs_model arg should be one of: mem_address_pc, cache_tag_index, cache_tag_only, cache_index_only, cache_tag_index_part, cache_tag_index_part_page, cache_speculation, cache_speculation_first, cache_straightline\n"); + print ("\nobs_model arg should be one of: mem_address_pc, mem_address_pc_lspc, cache_tag_index, cache_tag_only, cache_index_only, cache_tag_index_part, cache_tag_index_part_page, cache_speculation, cache_speculation_first, cache_straightline\n"); print ("\nrefined_obs_model arg is like obs_model\n"); print ("\nobs_projection is an observation id as a number\n"); print ("\nhw_obs_model arg should be one of: hw_cache_tag_index, hw_cache_index_numvalid, hw_cache_tag_index_part, hw_cache_tag_index_part_page\n"); From 67fb9b27964155714b8d80bbc2a0637a18a89aef Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Mon, 2 Aug 2021 17:49:19 +0200 Subject: [PATCH 0075/1015] Add library that provides initial states for lifter supported architectures with default values --- src/tools/lifter/bir_init_machinesLib.sml | 88 +++++++++++++++++++++++ 1 file changed, 88 insertions(+) create mode 100644 src/tools/lifter/bir_init_machinesLib.sml diff --git a/src/tools/lifter/bir_init_machinesLib.sml b/src/tools/lifter/bir_init_machinesLib.sml new file mode 100644 index 000000000..0a4c2e5dd --- /dev/null +++ b/src/tools/lifter/bir_init_machinesLib.sml @@ -0,0 +1,88 @@ +structure bir_init_machinesLib = +struct +local + + open HolKernel Parse boolLib bossLib; + + open listSyntax; + open combinSyntax; + + open bir_envSyntax; + open bir_lifting_machinesTheory; + + val evalthis = snd o dest_eq o concl o EVAL; + + val libname = "bir_init_machinesLib" + val ERR = Feedback.mk_HOL_ERR libname + val wrap_exn = Feedback.wrap_exn libname + +in + + (* + val bmr_rec = bir_lifting_machinesLib_instances.m0_bmr_rec_LittleEnd_Process; + *) + + fun get_init_state_from_bmr_rec (bmr_rec :bir_lifting_machinesLib.bmr_rec) = + let + val bmr_const = #bmr_const bmr_rec; + + val bmr_imms = evalthis “(^bmr_const).bmr_imms”; + val bmr_mem = evalthis “(^bmr_const).bmr_mem”; + + val bvar_imms = evalthis “MAP (\x. case x of BMLI bv _ => bv) (^bmr_imms)”; + val bvar_mem = evalthis “(\x. case x of BMLM bv _ => bv) (^bmr_mem)”; + val all_bvars = (bvar_mem)::((fst o dest_list) bvar_imms); + + (* the following is copied and adapted from src/tools/exec/bir_exec_envLib.sml -- to create default environment from a list of bir variables *) + val var_pairs = List.map dest_BVar all_bvars; + val var_assigns = List.map (fn (n,t) => + (n, ((snd o dest_eq o concl o EVAL) ``SOME (bir_default_value_of_type ^t)``))) var_pairs; + + fun list_mk_update ([], env) = env + | list_mk_update (h::l, env) = list_mk_update (l, mk_comb (mk_update h, env)); + + val bir_env_map_empty = evalthis “(\x. case x of BEnv env => env) bir_env_empty”; + val env_map = list_mk_update (var_assigns, bir_env_map_empty); + in + “BEnv (^env_map)” + end; + + + val init_state_arm8 = + get_init_state_from_bmr_rec + bir_lifting_machinesLib_instances.arm8_bmr_rec; + + val init_state_m0_LittleEnd_Main = + get_init_state_from_bmr_rec + bir_lifting_machinesLib_instances.m0_bmr_rec_LittleEnd_Main; + + val init_state_m0_BigEnd_Main = + get_init_state_from_bmr_rec + bir_lifting_machinesLib_instances.m0_bmr_rec_BigEnd_Main; + + val init_state_m0_LittleEnd_Process = + get_init_state_from_bmr_rec + bir_lifting_machinesLib_instances.m0_bmr_rec_LittleEnd_Process; + + val init_state_m0_BigEnd_Process = + get_init_state_from_bmr_rec + bir_lifting_machinesLib_instances.m0_bmr_rec_BigEnd_Process; + + val init_state_riscv = + get_init_state_from_bmr_rec + bir_lifting_machinesLib_instances.riscv_bmr_rec; + + +(* some simple assertions *) + val _ = if identical (init_state_m0_LittleEnd_Main) (init_state_m0_BigEnd_Main) then () else + raise ERR "assertion m0 \"LE_M == BE_M\"" "the states are expected to be identical terms"; + + val _ = if identical (init_state_m0_LittleEnd_Main) (init_state_m0_LittleEnd_Process) then () else + raise ERR "assertion m0 \"LE_M == LE_P\"" "the states are expected to be identical terms"; + + val _ = if identical (init_state_m0_LittleEnd_Main) (init_state_m0_BigEnd_Process) then () else + raise ERR "assertion m0 \"LE_M == BE_P\"" "the states are expected to be identical terms"; + +end (* local *) + +end (* struct *) From 3d0b2df0b0a159f0c777b2ffc459cbf4401db607 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 7 Oct 2021 09:50:59 +0200 Subject: [PATCH 0076/1015] Fix printf warnings in run-test.sh --- scripts/run-test.sh | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/scripts/run-test.sh b/scripts/run-test.sh index 239df406a..d3a0ad9d1 100755 --- a/scripts/run-test.sh +++ b/scripts/run-test.sh @@ -33,8 +33,8 @@ function stop_watcher { function test_failed_trap { declare END_TIME=$(date +%s.%N) - declare DURATION=$(python3 -c "print($END_TIME - $START_TIME)") - enclose "Test failed: $TEST_PATH" "$(printf 'Elapsed time: %3g sec.\n' "$DURATION")" + declare DURATION=$(python3 -c "print(round($END_TIME - $START_TIME, 2))") + enclose "Test failed: $TEST_PATH" "$(printf 'Elapsed time: %s sec.\n' "$DURATION")" stop_watcher } @@ -52,9 +52,9 @@ function test_script_file { #if (($RANDOM < 20000)); then exit 1; fi declare END_TIME=$(date +%s.%N) - declare DURATION=$(python3 -c "print($END_TIME - $START_TIME)") + declare DURATION=$(python3 -c "print(round($END_TIME - $START_TIME, 2))") - enclose "Test successful: $1" "$(printf "Elapsed time: %3g sec.\n" "$DURATION")" + enclose "Test successful: $1" "$(printf "Elapsed time: %s sec.\n" "$DURATION")" trap - EXIT # Remove the trap } From 5c54ed883c23f9cd8db377529d9a1c508ca427c3 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 7 Oct 2021 17:02:44 +0200 Subject: [PATCH 0077/1015] Added HOL4 to Github Actions matrix --- .github/workflows/build.yaml | 4 +++- scripts/setup/install_hol4.sh | 19 +++++++++++-------- scripts/setup/install_hol4_latest.sh | 6 ++---- scripts/setup/install_poly.sh | 4 ++-- 4 files changed, 18 insertions(+), 15 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 394f623bf..bfc082472 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -18,9 +18,11 @@ jobs: strategy: matrix: polyml: ['v5.7.1', 'v5.8.1'] + hol4: ['kananaskis-14'] env: HOLBA_POLYML_VERSION: ${{ matrix.polyml }} + HOLBA_HOL4_VERSION: ${{ matrix.hol4 }} steps: - name: Checkout code @@ -32,7 +34,7 @@ jobs: with: path: | ${{ env.HOLBA_OPT_DIR }} - key: os-${{ runner.os }}_polyml-${{ matrix.polyml }}_hol4-k14 + key: os-${{ runner.os }}_polyml-${{ matrix.polyml }}_hol4-${{ matrix.hol4 }} - name: Static analysis timeout-minutes: 5 diff --git a/scripts/setup/install_hol4.sh b/scripts/setup/install_hol4.sh index c22873c58..a5818654c 100755 --- a/scripts/setup/install_hol4.sh +++ b/scripts/setup/install_hol4.sh @@ -15,22 +15,25 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## - -# make polyml binaries and libraries available +# use a default polyml version if it is not specified in the environment POLY_VERSION="v5.8.1" - -# if poly version is specified in the environment, use this if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi +# make polyml binaries and libraries available POLY_DIR=${HOLBA_OPT_DIR}/polyml_${POLY_VERSION} export PATH=${POLY_DIR}/bin:$PATH export LD_LIBRARY_PATH=${POLY_DIR}/lib:$LD_LIBRARY_PATH +# use a default hol4 version if it is not specified in the environment +HOL4_VERSION="kananaskis-14" +if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then + HOL4_VERSION=${HOLBA_POLYML_VERSION} +fi + # HOL4 source and branch GIT_URL=https://github.com/HOL-Theorem-Prover/HOL.git -GIT_BRANCH=kananaskis-14 GIT_IS_TAG=1 HOL4_DIR=${HOLBA_OPT_DIR}/hol_k14 @@ -48,7 +51,7 @@ if [[ -d "${HOL4_DIR}" ]]; then git fetch origin # does the remote branch exist locally? - if [[ ! `git branch --all --list origin/${GIT_BRANCH}` ]]; then + if [[ ! `git branch --all --list origin/${HOL4_VERSION}` ]]; then echo "the cached HOL4 version seems to be on another branch, deleting it now" # delete the stale HOL4 build cd "${HOLBA_OPT_DIR}" @@ -56,7 +59,7 @@ if [[ -d "${HOL4_DIR}" ]]; then else # is there a difference between the current and the remote branch? GIT_DIFF=$(git diff) - GIT_DIFF_REMOTE=$(git diff HEAD remotes/origin/${GIT_BRANCH}) + GIT_DIFF_REMOTE=$(git diff HEAD remotes/origin/${HOL4_VERSION}) if [[ "${GIT_DIFF}${GIT_DIFF_REMOTE}" ]]; then echo "the cached HOL4 version has differences, deleting it now" # delete the stale HOL4 build @@ -74,7 +77,7 @@ cd "${HOLBA_OPT_DIR}" # if HOL does not exist already, clone and build it if [[ ! -d "${HOL4_DIR}" ]]; then # clone the specified HOL4 branch only - git clone -b ${GIT_BRANCH} --single-branch ${GIT_URL} "${HOL4_DIR}" + git clone -b ${HOL4_VERSION} --single-branch ${GIT_URL} "${HOL4_DIR}" cd "${HOL4_DIR}" # compile HOL4 diff --git a/scripts/setup/install_hol4_latest.sh b/scripts/setup/install_hol4_latest.sh index c4e2aaca8..916c8c8ed 100755 --- a/scripts/setup/install_hol4_latest.sh +++ b/scripts/setup/install_hol4_latest.sh @@ -15,15 +15,13 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## - -# make polyml binaries and libraries available +# use a default polyml version if it is not specified in the environment POLY_VERSION="v5.8.1" - -# if poly version is specified in the environment, use this if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi +# make polyml binaries and libraries available POLY_DIR=${HOLBA_OPT_DIR}/polyml_${POLY_VERSION} export PATH=${POLY_DIR}/bin:$PATH export LD_LIBRARY_PATH=${POLY_DIR}/lib:$LD_LIBRARY_PATH diff --git a/scripts/setup/install_poly.sh b/scripts/setup/install_poly.sh index ccbe3950f..1b7673f89 100755 --- a/scripts/setup/install_poly.sh +++ b/scripts/setup/install_poly.sh @@ -19,9 +19,9 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" # based on HOL4 developers/install-poly.sh # -------------------------------------------- POLY_BASE="https://github.com/polyml/polyml" -POLY_VERSION="v5.8.1" -# if poly version is specified in the environment, use this +# use a default polyml version if it is not specified in the environment +POLY_VERSION="v5.8.1" if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi From df72ca9a80f9f6d1ddf86b279823064ef8be1f18 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 7 Oct 2021 17:09:53 +0200 Subject: [PATCH 0078/1015] Typo in HOL4 install script --- scripts/setup/install_hol4.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/setup/install_hol4.sh b/scripts/setup/install_hol4.sh index a5818654c..562a12dac 100755 --- a/scripts/setup/install_hol4.sh +++ b/scripts/setup/install_hol4.sh @@ -28,8 +28,8 @@ export LD_LIBRARY_PATH=${POLY_DIR}/lib:$LD_LIBRARY_PATH # use a default hol4 version if it is not specified in the environment HOL4_VERSION="kananaskis-14" -if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then - HOL4_VERSION=${HOLBA_POLYML_VERSION} +if [[ ! -z "${HOLBA_HOL4_VERSION}" ]]; then + HOL4_VERSION=${HOLBA_HOL4_VERSION} fi # HOL4 source and branch From b5e82ba4dfed9034b75d031c8b57c98be6c1f38b Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 26 Nov 2021 09:55:06 +0100 Subject: [PATCH 0079/1015] Added Poly/ML v5.9, removed selftest_styleLib --- .github/workflows/build.yaml | 2 +- src/tools/lifter/selftestLib.sml | 7 ++++++- src/tools/lifter/selftest_styleLib.sig | 11 ----------- src/tools/lifter/selftest_styleLib.sml | 13 ------------- 4 files changed, 7 insertions(+), 26 deletions(-) delete mode 100644 src/tools/lifter/selftest_styleLib.sig delete mode 100644 src/tools/lifter/selftest_styleLib.sml diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index bfc082472..c95562180 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -17,7 +17,7 @@ jobs: strategy: matrix: - polyml: ['v5.7.1', 'v5.8.1'] + polyml: ['v5.8.1', 'v5.9'] hol4: ['kananaskis-14'] env: diff --git a/src/tools/lifter/selftestLib.sml b/src/tools/lifter/selftestLib.sml index a4c602f6b..00a6d2150 100644 --- a/src/tools/lifter/selftestLib.sml +++ b/src/tools/lifter/selftestLib.sml @@ -44,13 +44,18 @@ open PPBackEnd Parse open bir_inst_liftingHelpersLib; -open selftest_styleLib; (* ================================================ *) open HolKernel Parse; open testutils; open PPBackEnd; open bir_inst_liftingLib; + + val sty_OK = [FG Green]; + val sty_CACHE = [FG Yellow]; + val sty_FAIL = [FG OrangeRed]; + val sty_HEADER = [Bold, Underline]; + in (* Error at this point is only due to REPL not knowing difference between struct and module *) open MD; diff --git a/src/tools/lifter/selftest_styleLib.sig b/src/tools/lifter/selftest_styleLib.sig deleted file mode 100644 index 98277d8e6..000000000 --- a/src/tools/lifter/selftest_styleLib.sig +++ /dev/null @@ -1,11 +0,0 @@ -signature selftest_styleLib = sig - - include PPBackEnd; - - (* TODO: Put test instances here? *) - val sty_OK : pp_style list - val sty_CACHE : pp_style list - val sty_FAIL : pp_style list - val sty_HEADER : pp_style list - -end; diff --git a/src/tools/lifter/selftest_styleLib.sml b/src/tools/lifter/selftest_styleLib.sml deleted file mode 100644 index 865d11404..000000000 --- a/src/tools/lifter/selftest_styleLib.sml +++ /dev/null @@ -1,13 +0,0 @@ -structure selftest_styleLib :> selftest_styleLib = struct - - open PPBackEnd; - - (* TODO: Put test instances here? *) - - (* Styles for success, fail and header *) - val sty_OK = [FG Green]; - val sty_CACHE = [FG Yellow]; - val sty_FAIL = [FG OrangeRed]; - val sty_HEADER = [Bold, Underline]; - -end; From a3c56ff325889bb648bb39f608b33078f9e9caff Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 29 Nov 2021 11:30:36 +0100 Subject: [PATCH 0080/1015] Fixes to lifter tests --- .../lifter/bir_inst_liftingHelpersLib.sml | 2 +- src/tools/lifter/bir_inst_liftingLib.sml | 2 -- src/tools/lifter/selftestLib.sig | 5 +++ src/tools/lifter/selftestLib.sml | 34 +++++-------------- src/tools/lifter/selftest_riscv.sml | 2 +- 5 files changed, 15 insertions(+), 30 deletions(-) diff --git a/src/tools/lifter/bir_inst_liftingHelpersLib.sml b/src/tools/lifter/bir_inst_liftingHelpersLib.sml index b5ce7e6bb..602c76c58 100644 --- a/src/tools/lifter/bir_inst_liftingHelpersLib.sml +++ b/src/tools/lifter/bir_inst_liftingHelpersLib.sml @@ -4,8 +4,8 @@ struct local open HolKernel boolLib liteLib simpLib Parse bossLib; +open PPBackEnd open bir_inst_liftingLibTypes -open PPBackEnd Parse in diff --git a/src/tools/lifter/bir_inst_liftingLib.sml b/src/tools/lifter/bir_inst_liftingLib.sml index 673c2a0dd..f07376496 100644 --- a/src/tools/lifter/bir_inst_liftingLib.sml +++ b/src/tools/lifter/bir_inst_liftingLib.sml @@ -13,8 +13,6 @@ open bir_lifting_machinesTheory open bir_lifting_machinesLib bir_lifting_machinesLib_instances; open bir_interval_expTheory bir_update_blockTheory open bir_exp_liftingLib bir_typing_expSyntax -open bir_typing_expTheory -open bir_extra_expsTheory open bir_lifter_general_auxTheory open bir_programSyntax bir_interval_expSyntax open bir_program_labelsTheory diff --git a/src/tools/lifter/selftestLib.sig b/src/tools/lifter/selftestLib.sig index acd35d67c..84373caec 100644 --- a/src/tools/lifter/selftestLib.sig +++ b/src/tools/lifter/selftestLib.sig @@ -3,6 +3,11 @@ signature selftestLib = sig include PPBackEnd; + val sty_OK : pp_style list + val sty_CACHE : pp_style list + val sty_FAIL : pp_style list + val sty_HEADER : pp_style list + end; signature test_bmr = sig diff --git a/src/tools/lifter/selftestLib.sml b/src/tools/lifter/selftestLib.sml index 00a6d2150..469948cfe 100644 --- a/src/tools/lifter/selftestLib.sml +++ b/src/tools/lifter/selftestLib.sml @@ -8,6 +8,10 @@ structure selftestLib :> selftestLib = struct open PPBackEnd; (* TODO: Put test instances here? *) + val sty_OK = [FG Green]; + val sty_CACHE = [FG Yellow]; + val sty_FAIL = [FG OrangeRed]; + val sty_HEADER = [Bold, Underline]; end; @@ -24,33 +28,11 @@ end; *) local -(* these dependencies probably need cleanup *) -(* ================================================ *) -open HolKernel boolLib liteLib simpLib Parse bossLib; -open bir_inst_liftingTheory -open bir_lifting_machinesTheory -open bir_lifting_machinesLib bir_lifting_machinesLib_instances; -open bir_interval_expTheory bir_update_blockTheory -open bir_exp_liftingLib bir_typing_expSyntax -open bir_typing_expTheory -open bir_extra_expsTheory -open bir_lifter_general_auxTheory -open bir_programSyntax bir_interval_expSyntax -open bir_program_labelsTheory -open bir_immTheory -open intel_hexLib -open bir_inst_liftingLibTypes -open PPBackEnd Parse - -open bir_inst_liftingHelpersLib; - -(* ================================================ *) - - open HolKernel Parse; - open testutils; - open PPBackEnd; - open bir_inst_liftingLib; + open HolKernel boolLib liteLib simpLib Parse bossLib; + open PPBackEnd; + open bir_inst_liftingLibTypes bir_inst_liftingHelpersLib; + (* TODO: Ideally, these should not be defined twice *) val sty_OK = [FG Green]; val sty_CACHE = [FG Yellow]; val sty_FAIL = [FG OrangeRed]; diff --git a/src/tools/lifter/selftest_riscv.sml b/src/tools/lifter/selftest_riscv.sml index 9996be5bd..c7907bc35 100644 --- a/src/tools/lifter/selftest_riscv.sml +++ b/src/tools/lifter/selftest_riscv.sml @@ -4,7 +4,6 @@ open bir_inst_liftingLib; open PPBackEnd open riscv_assemblerLib; open selftestLib; -open selftest_styleLib; (* Flags for determining type of output *) val unicode = false; @@ -29,6 +28,7 @@ val mu_b = Arbnum.fromInt 0; (* Memory starts at address 0x0 *) val mu_e = Arbnum.fromInt 0x1000000; (* Memory ends at address 0x1000000 *) val pc = Arbnum.fromInt 0x10030; (* Program counter is at address 0x10030 *) + (******************************) (* Shorthands from test_RISCV *) (******************************) From 9718978ceb264040e222a4087308e720f3f14b8d Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 29 Nov 2021 13:34:36 +0100 Subject: [PATCH 0081/1015] ARM selftest --- src/tools/lifter/selftest_arm.sml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/tools/lifter/selftest_arm.sml b/src/tools/lifter/selftest_arm.sml index f9100cd83..cecfe6487 100644 --- a/src/tools/lifter/selftest_arm.sml +++ b/src/tools/lifter/selftest_arm.sml @@ -5,7 +5,6 @@ open bir_inst_liftingLibTypes; open bir_inst_liftingHelpersLib; open PPBackEnd; -open selftest_styleLib; open selftestLib; (******************) From de35faf1b4198fc358a3897aeb8229183afb9e6c Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Wed, 1 Dec 2021 15:22:05 +0100 Subject: [PATCH 0082/1015] Added Z3 version to CI --- .github/workflows/build.yaml | 7 +++++-- README.md | 2 +- scripts/setup/install_poly.sh | 2 +- scripts/setup/install_z3.sh | 14 ++++++++++++-- scripts/setup/install_z3_src.sh | 6 +++++- 5 files changed, 24 insertions(+), 7 deletions(-) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index c95562180..22dbe6571 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -17,11 +17,14 @@ jobs: strategy: matrix: - polyml: ['v5.8.1', 'v5.9'] + polyml: ['v5.7.1', 'v5.9'] + z3: ['4.8.4'] hol4: ['kananaskis-14'] env: HOLBA_POLYML_VERSION: ${{ matrix.polyml }} + HOLBA_Z3_VERSION: ${{ matrix.z3 }} + HOLBA_Z3_ASSET_SUFFIX: '.d6df51951f4c-x64-debian-8.11.zip' HOLBA_HOL4_VERSION: ${{ matrix.hol4 }} steps: @@ -34,7 +37,7 @@ jobs: with: path: | ${{ env.HOLBA_OPT_DIR }} - key: os-${{ runner.os }}_polyml-${{ matrix.polyml }}_hol4-${{ matrix.hol4 }} + key: os-${{ runner.os }}_polyml-${{ matrix.polyml }}_z3-${{ matrix.z3 }}_hol4-${{ matrix.hol4 }} - name: Static analysis timeout-minutes: 5 diff --git a/README.md b/README.md index ccbd52678..4a289ee7b 100644 --- a/README.md +++ b/README.md @@ -61,7 +61,7 @@ ${HOLBA_HOLMAKE} - HOL4 (`https://github.com/HOL-Theorem-Prover/HOL`) - tag: kananaskis-14 -- Poly/ML 5.8.1 +- Poly/ML 5.9 - alternatively, Poly/ML 5.7.1 (version packaged for Ubuntu 20.04) - Z3 v4.8.4 diff --git a/scripts/setup/install_poly.sh b/scripts/setup/install_poly.sh index 1b7673f89..0c3318825 100755 --- a/scripts/setup/install_poly.sh +++ b/scripts/setup/install_poly.sh @@ -21,7 +21,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" POLY_BASE="https://github.com/polyml/polyml" # use a default polyml version if it is not specified in the environment -POLY_VERSION="v5.8.1" +POLY_VERSION="v5.9" if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index 8c9cab0f1..443086070 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -15,11 +15,21 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## +# use a default z3 version if it is not specified in the environment +Z3_VERSION="4.8.4" +if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then + Z3_VERSION=${HOLBA_POLYML_VERSION} +fi + +Z3_ASSET_SUFFIX=".d6df51951f4c-x64-debian-8.11.zip" +if [[ ! -z "${HOLBA_Z3_ASSET_SUFFIX}" ]]; then + Z3_ASSET_SUFFIX=${HOLBA_Z3_ASSET_SUFFIX} +fi # download package -Z3_URL="https://github.com/Z3Prover/z3/releases/download/z3-4.8.4/z3-4.8.4.d6df51951f4c-x64-debian-8.11.zip" +Z3_URL="https://github.com/Z3Prover/z3/releases/download/z3-${Z3_VERSION}/z3-${Z3_VERSION}${Z3_ASSET_SUFFIX}" -Z3_DIR=${HOLBA_OPT_DIR}/z3-4.8.4.d6df51951f4c +Z3_DIR=${HOLBA_OPT_DIR}/z3-${Z3_VERSION} diff --git a/scripts/setup/install_z3_src.sh b/scripts/setup/install_z3_src.sh index e00b18b99..cdf89dabe 100755 --- a/scripts/setup/install_z3_src.sh +++ b/scripts/setup/install_z3_src.sh @@ -15,10 +15,14 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## +# use a default z3 version if it is not specified in the environment +Z3_VERSION="4.8.4" +if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then + Z3_VERSION=${HOLBA_POLYML_VERSION} +fi # download package Z3_BASE="https://github.com/Z3Prover/z3" -Z3_VERSION="4.8.4" Z3_URL=${Z3_BASE}/archive/z3-${Z3_VERSION}.tar.gz Z3_DIR=${HOLBA_OPT_DIR}/z3_${Z3_VERSION} From 470ac2c2465561a754e5a0c5b5fd8daec9ded708 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Wed, 1 Dec 2021 15:55:55 +0100 Subject: [PATCH 0083/1015] Typo in Z3 installation --- scripts/setup/env_config_gen.sh | 2 +- scripts/setup/install_z3.sh | 4 ++-- scripts/setup/install_z3_src.sh | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/scripts/setup/env_config_gen.sh b/scripts/setup/env_config_gen.sh index e7072cbcd..c5f8e3eb9 100755 --- a/scripts/setup/env_config_gen.sh +++ b/scripts/setup/env_config_gen.sh @@ -131,7 +131,7 @@ echo ####### HOLBA_Z3_DIR if [[ ( -z "${HOLBA_Z3_DIR}" ) || ( ! -z "${OPT_DIR_PARAM}" ) ]]; then - Z3_DIR="${HOLBA_OPT_DIR}/z3-4.8.4.d6df51951f4c" + Z3_DIR="${HOLBA_OPT_DIR}/z3-4.8.4" if [[ -d "${Z3_DIR}/bin/python" ]]; then print_export_msg "HOLBA_Z3_DIR" export HOLBA_Z3_DIR="${Z3_DIR}" diff --git a/scripts/setup/install_z3.sh b/scripts/setup/install_z3.sh index 443086070..4cc876ab1 100755 --- a/scripts/setup/install_z3.sh +++ b/scripts/setup/install_z3.sh @@ -17,8 +17,8 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" # use a default z3 version if it is not specified in the environment Z3_VERSION="4.8.4" -if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then - Z3_VERSION=${HOLBA_POLYML_VERSION} +if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then + Z3_VERSION=${HOLBA_Z3_VERSION} fi Z3_ASSET_SUFFIX=".d6df51951f4c-x64-debian-8.11.zip" diff --git a/scripts/setup/install_z3_src.sh b/scripts/setup/install_z3_src.sh index cdf89dabe..320fce35d 100755 --- a/scripts/setup/install_z3_src.sh +++ b/scripts/setup/install_z3_src.sh @@ -17,8 +17,8 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" # use a default z3 version if it is not specified in the environment Z3_VERSION="4.8.4" -if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then - Z3_VERSION=${HOLBA_POLYML_VERSION} +if [[ ! -z "${HOLBA_Z3_VERSION}" ]]; then + Z3_VERSION=${HOLBA_Z3_VERSION} fi # download package From 9046df67701db4d046d2eb994b45477993ead5f1 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 3 Dec 2021 11:47:17 +0100 Subject: [PATCH 0084/1015] Changed default Poly/ML version --- scripts/setup/install_hol4.sh | 2 +- scripts/setup/install_hol4_latest.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/setup/install_hol4.sh b/scripts/setup/install_hol4.sh index 562a12dac..6e306a406 100755 --- a/scripts/setup/install_hol4.sh +++ b/scripts/setup/install_hol4.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default polyml version if it is not specified in the environment -POLY_VERSION="v5.8.1" +POLY_VERSION="v5.9" if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi diff --git a/scripts/setup/install_hol4_latest.sh b/scripts/setup/install_hol4_latest.sh index 916c8c8ed..21e89b911 100755 --- a/scripts/setup/install_hol4_latest.sh +++ b/scripts/setup/install_hol4_latest.sh @@ -16,7 +16,7 @@ source "${SETUP_DIR}/env_config_gen.sh" "${OPT_DIR_PARAM}" ################################################################## # use a default polyml version if it is not specified in the environment -POLY_VERSION="v5.8.1" +POLY_VERSION="v5.9" if [[ ! -z "${HOLBA_POLYML_VERSION}" ]]; then POLY_VERSION=${HOLBA_POLYML_VERSION} fi From 59c5259b48db9fe76c942c1368fc18118ac74cb7 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 25 Mar 2022 10:40:04 +0100 Subject: [PATCH 0085/1015] Updated CI to run on a weekly schedule, preventing cache eviction --- .github/workflows/build.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml index 22dbe6571..a45d6f365 100644 --- a/.github/workflows/build.yaml +++ b/.github/workflows/build.yaml @@ -1,6 +1,8 @@ name: CI Build on: + schedule: + - cron: "0 3 * * 0" push: branches: [ '**' ] pull_request: From 8b1d1d4c42940ae82ad54f768d4fd63acda17a83 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 12 Jun 2020 13:36:47 +0200 Subject: [PATCH 0086/1015] Partial L_A judgment sketch --- .../abstract_hoare_logicScript.sml | 18 +- .../abstract_hoare_logic_partialScript.sml | 271 ++++++++++++++++++ 2 files changed, 280 insertions(+), 9 deletions(-) create mode 100644 src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index 3fb9b83a4..245fe9fe7 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -65,8 +65,8 @@ REV_FULL_SIMP_TAC arith_ss [] ); -val weak_unique_thm = prove(`` - !m. +val weak_unique_thm = store_thm("weak_unique_thm", +``!m. (weak_model m) ==> !ms ls ms' ms''. (m.weak ms ls ms') ==> @@ -102,7 +102,7 @@ Q.EXISTS_TAC `n` >> METIS_TAC [pred_setTheory.IN_UNION] ); -val weak_union2_thm = prove(`` +val weak_union2_thm = store_thm("weak_union2_thm",`` !m. weak_model m ==> !ms ls1 ls2 ms'. @@ -137,11 +137,11 @@ METIS_TAC [weak_model_def, pred_setTheory.IN_SING] ); -val weak_pc_in_thm = prove(`` - !m. - weak_model m ==> - !ms ls ms'. - (m.weak ms ls ms') ==> ((m.pc ms') IN ls)``, +val weak_pc_in_thm = store_thm("weak_pc_in_thm", + ``!m. + weak_model m ==> + !ms ls ms'. + (m.weak ms ls ms') ==> ((m.pc ms') IN ls)``, METIS_TAC [weak_model_def] ); @@ -237,7 +237,7 @@ val abstract_subset_rule_thm = REPEAT STRIP_TAC >> REV_FULL_SIMP_TAC std_ss [abstract_jgmt_def] >> REPEAT STRIP_TAC >> -QSPECL_X_ASSUM ``!x. _`` [`ms`] >> +QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> METIS_TAC [weak_union_pc_not_in_thm] ); diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml new file mode 100644 index 000000000..197938cf1 --- /dev/null +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -0,0 +1,271 @@ +open HolKernel Parse boolLib bossLib; + +open bir_auxiliaryLib; + +open bir_auxiliaryTheory; + +open abstract_hoare_logicTheory; + +val _ = new_theory "abstract_hoare_logic_partial"; + +(* +val weak_subset_thm = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms' n. + (n > 0 /\ (FUNPOW_OPT m.trs n ms = SOME ms') /\ m.pc ms' IN ls1 /\ + !n'. + n' < n /\ n' > 0 ==> + ?ms''. + (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ m.pc ms'' NOTIN ls1) + ==> + ?ms'' n'. + (n' <= n /\ n' > 0 /\ (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ + m.pc ms'' IN ls1 UNION ls2) /\ + !n''. + n'' < n' /\ n'' > 0 ==> + ?ms''. + (FUNPOW_OPT m.trs n'' ms = SOME ms'') /\ + m.pc ms'' NOTIN ls1 UNION ls2``, + +cheat +); +*) + +val weak_not_union_thm = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + ~(m.weak ms (ls1 UNION ls2) ms') ==> + ~(m.weak ms ls1 ms') /\ ~(m.weak ms ls2 ms')``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >| [ + QSPECL_X_ASSUM ``!n. + (~(n > 0) \/ FUNPOW_OPT m.trs n ms <> SOME ms' \/ + m.pc ms' NOTIN ls1 UNION ls2) \/ + ?n'. + (n' < n /\ n' > 0) /\ + !ms''. + FUNPOW_OPT m.trs n' ms <> SOME ms'' \/ + m.pc ms'' IN ls1 UNION ls2`` [`n`] >> ( + FULL_SIMP_TAC (arith_ss++pred_setLib.PRED_SET_ss) [] + ) >> + QSPECL_X_ASSUM ``!(n':num). n' < n /\ n' > 0 ==> _`` [`n'`] >> + REV_FULL_SIMP_TAC arith_ss [] >> + QSPECL_X_ASSUM ``!ms''. _`` [`ms''`] >> + +] +cheat +); + +(* Definition of the triple *) +(* Pre and post usually have conditions on execution mode and code in memory *) +(* also post is usually a map that depends on the end state address *) +val weak_partial_triple_def = Define ` + weak_partial_triple m (l:'a) (ls:'a->bool) pre post = + !ms ms'. + ((m.pc ms) = l) ==> + pre ms ==> + m.weak ms ls ms' ==> + post ms' +`; + +val weak_triple_imp_partial_triple = + store_thm("weak_triple_imp_partial_triple", + ``!m l ls pre post. + weak_model m ==> + weak_triple m l ls pre post ==> + weak_partial_triple m l ls pre post``, + +FULL_SIMP_TAC std_ss [weak_triple_def, weak_partial_triple_def] >> +REPEAT STRIP_TAC >> +QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> +METIS_TAC [weak_unique_thm] +); + +val weak_partial_case_rule_thm = prove(`` +!m l ls pre post C1. + weak_partial_triple m l ls (\ms. (pre ms) /\ (C1 ms)) post ==> + weak_partial_triple m l ls (\ms. (pre ms) /\ (~(C1 ms))) post ==> + weak_partial_triple m l ls pre post +``, + +REPEAT STRIP_TAC >> +FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +METIS_TAC [] +); + +val weak_partial_weakening_rule_thm = + store_thm("weak_partial_weakening_rule_thm", + ``!m. + !l ls pre1 pre2 post1 post2. + weak_model m ==> + (!ms. ((m.pc ms) = l) ==> (pre2 ms) ==> (pre1 ms)) ==> + (!ms. ((m.pc ms) IN ls) ==> (post1 ms) ==> (post2 ms)) ==> + weak_partial_triple m l ls pre1 post1 ==> + weak_partial_triple m l ls pre2 post2 + ``, + +SIMP_TAC std_ss [weak_partial_triple_def] >> +REPEAT STRIP_TAC >> +IMP_RES_TAC weak_pc_in_thm >> +METIS_TAC [weak_pc_in_thm] +); + + +(* TODO: This is introduced since negating m.weak gets weird *) +val trs_in_lblset_def = Define ` + trs_in_lblset m ms n ls = + let + ms'_opt = FUNPOW_OPT m.trs n ms + in + if IS_NONE ms'_opt + then F + else if m.pc (THE ms'_opt) IN ls + then T + else F +`; + +val weak_partial_subset_rule_thm = + store_thm("weak_partial_subset_rule_thm", + ``!m. ! l ls1 ls2 pre post . + weak_model m ==> + (!ms. ((post ms) ==> (~((m.pc ms) IN ls2)))) ==> + weak_partial_triple m l (ls1 UNION ls2) pre post ==> + weak_partial_triple m l ls1 pre post``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +REPEAT STRIP_TAC >> +QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> +REV_FULL_SIMP_TAC std_ss [] >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +(* Either execution from ms to ms' encounters ls2 along the way, or not. *) +Cases_on `?n'. n' <= n /\ n' > 0 ==> trs_in_lblset m ms n' ls2` >| [ + (* Case yes: Then there must be a first time (as in, the encounter with least amount of steps + * taken) ls2 is encountered (needs separate proof), say after n' steps in state ms''. + * So, (m.pc ms'' IN ls2) and m.weak ms (ls1 UNION ls2) ms'' (since no ls1 encountered from + * m.weak ms ls1 ms') but with + * !ms''. m.weak ms (ls1 UNION ls2) ms'' ==> post ms'' you can then derive that post ms'', which is + * contradicted by !ms. post ms ==> m.pc ms NOTIN ls2. *) + subgoal `?n''. !n'''. n''' < n'' /\ n'' > 0 ==> ~trs_in_lblset m ms n''' ls` >- ( + Q.EXISTS_TAC `n'` >> + cheat + ) >> + cheat, + + (* Case no: m.weak ms ls1 ms' can be expanded to m.weak ms (ls1 UNION ls2) ms' + * and be used with !ms''. m.weak ms (ls1 UNION ls2) ms'' ==> post ms'' to obtain + * post ms'. *) + FULL_SIMP_TAC std_ss [] >> + `?n'. + ((FUNPOW_OPT m.trs n' ms = SOME ms') /\ + m.pc ms' IN ls1 UNION ls2) /\ + !n''. + n'' < n' ==> + ?ms''. + (FUNPOW_OPT m.trs n'' ms = SOME ms'') /\ + m.pc ms'' NOTIN ls1 UNION ls2` suffices_by ( + METIS_TAC [] + ) >> + Q.EXISTS_TAC `n` >> + REPEAT STRIP_TAC >> ( + FULL_SIMP_TAC (arith_ss++pred_setLib.PRED_SET_ss) [] + ) >> + QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> + FULL_SIMP_TAC std_ss [trs_in_lblset_def, LET_DEF] >| [ + (* Contradiction: Cannot be NONE for n'' steps, then return to SOME for n steps *) + cheat, + + subgoal `?ms''. FUNPOW_OPT m.trs n'' ms = SOME ms''` >- ( + (* Contradiction: Cannot be NONE for n'' steps, then return to SOME for n steps *) + cheat + ) >> + FULL_SIMP_TAC std_ss [] >> + QSPECL_X_ASSUM ``!n'. + n' < n ==> + ?ms''. + (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ m.pc ms'' NOTIN ls1`` [`n''`] >> + REV_FULL_SIMP_TAC std_ss [] + ] +] +); + + +val weak_partial_conj_rule_thm = prove(`` + !m. + weak_model m ==> + !l ls pre post1 post2. + weak_partial_triple m l ls pre post1 ==> + weak_partial_triple m l ls pre post2 ==> + weak_partial_triple m l ls pre (\ms. (post1 ms) /\ (post2 ms))``, + +REPEAT STRIP_TAC >> +FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +REPEAT STRIP_TAC >> +METIS_TAC [weak_unique_thm] +); + + +val weak_partial_seq_rule_thm = store_thm("weak_partial_seq_rule_thm", + ``!m l ls1 ls2 pre post. + weak_model m ==> + weak_partial_triple m l (ls1 UNION ls2) pre post ==> + (!l1. (l1 IN ls1) ==> + (weak_partial_triple m l1 ls2 post post)) ==> + weak_partial_triple m l ls2 pre post``, + +REPEAT STRIP_TAC >> +FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +REPEAT STRIP_TAC >> +QSPECL_X_ASSUM ``!ms ms'. + (m.pc ms = l) ==> + pre ms ==> + m.weak ms (ls1 UNION ls2) ms' ==> + post ms'`` [`ms`] >> +REV_FULL_SIMP_TAC std_ss [] >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +(* Case split on whether ls1 was visited before ms'. *) +Cases_on `?n'. n' <= n /\ n' > 0 ==> trs_in_lblset m ms n' ls1` >| [ + (* Case yes: Then there must be a first time (as in, the encounter with least amount of steps + * taken) ls1 is encountered (needs separate proof), say after n' steps in state ms''. + * So, (m.pc ms'' IN ls1) and m.weak ms (ls1 UNION ls2) ms'' (since no ls2 encountered from + * m.weak ms ls2 ms') but with + * !l1. + l1 IN ls1 ==> + !ms ms'. + (m.pc ms = l1) ==> + post ms ==> + m.weak ms ls2 ms' ==> + post ms' you can then derive that post ms'. *) + cheat, + + (* Case no: m.weak ms ls1 ms' can be expanded to m.weak ms (ls1 UNION ls2) ms' + * and be used with !ms''. m.weak ms (ls1 UNION ls2) ms'' ==> post ms'' to obtain + * post ms'. *) + cheat +] +); + + + +val weak_partial_loop_contract_def = Define ` + weak_partial_loop_contract m l le invariant C1 var = + (~(l IN le)) /\ + (weak_partial_triple m l ({l} UNION le) (\ms. (invariant ms) /\ (C1 ms)) + (\ms.(((m.pc ms)=l) /\ (invariant ms)))) +`; +(* TODO: Preliminaries for proving partial loop rule *) +val weak_partial_loop_rule_thm = store_thm("weak_partial_loop_rule_thm", + ``!m. + weak_model m ==> + !l le invariant C1 var post. + weak_partial_loop_contract m l le invariant C1 var ==> + weak_partial_triple m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> + weak_partial_triple m l le invariant post``, + +cheat +); + +val _ = export_theory(); From aae02badb9f8499bb6275da71ada4be13101cc84 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 22 Apr 2022 17:03:42 +0200 Subject: [PATCH 0087/1015] Fixed proof of weak_partial_subset_rule_thm by adding cheat lemma weak_rel_steps_smallest_exists --- .../abstract_hoare_logicScript.sml | 2 +- .../abstract_hoare_logic_partialScript.sml | 320 ++++++++++-------- 2 files changed, 188 insertions(+), 134 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index 245fe9fe7..e45148e7a 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -18,7 +18,7 @@ val _ = Datatype `abstract_model_t = pc : 'a -> 'b |>`; -(* An abstract model is a weak model, if this property is fulfilled. +(* An abstract model is a weak model if this property is fulfilled. * This is how the weak transition is forced to be related to * the single transition. *) val weak_model_def = Define ` diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 197938cf1..54f2162c3 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -8,62 +8,157 @@ open abstract_hoare_logicTheory; val _ = new_theory "abstract_hoare_logic_partial"; -(* -val weak_subset_thm = prove(`` +val weak_rel_steps_def = Define ` + weak_rel_steps m ms ls ms' n = + ((n > 0 /\ + FUNPOW_OPT m.trs n ms = SOME ms' /\ + m.pc ms' IN ls) /\ + !n'. + (n' < n /\ n' > 0 ==> + ?ms''. + FUNPOW_OPT m.trs n' ms = SOME ms'' /\ + ~(m.pc ms'' IN ls) + ))`; + +val weak_rel_steps_equiv = prove(`` + !m ms ls ms'. + weak_model m ==> + (m.weak ms ls ms' <=> + ?n. weak_rel_steps m ms ls ms' n) + ``, + +REPEAT STRIP_TAC >> +EQ_TAC >> ( + STRIP_TAC +) >| [ + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + Q.EXISTS_TAC `n` >> + fs [weak_rel_steps_def], + + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + fs [weak_rel_steps_def] >> + Q.EXISTS_TAC `n` >> + REPEAT STRIP_TAC >> ( + fs [] + ) +] +); + +val weak_rel_steps_label = prove(`` + !m ms ls ms' n. + weak_model m ==> + weak_rel_steps m ms ls ms' n ==> + m.pc ms' IN ls + ``, + +fs [weak_rel_steps_def] +); + +val weak_rel_steps_smallest_exists = prove(`` !m. weak_model m ==> - !ms ls1 ls2 ms' n. - (n > 0 /\ (FUNPOW_OPT m.trs n ms = SOME ms') /\ m.pc ms' IN ls1 /\ - !n'. - n' < n /\ n' > 0 ==> - ?ms''. - (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ m.pc ms'' NOTIN ls1) - ==> - ?ms'' n'. - (n' <= n /\ n' > 0 /\ (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ - m.pc ms'' IN ls1 UNION ls2) /\ - !n''. - n'' < n' /\ n'' > 0 ==> - ?ms''. - (FUNPOW_OPT m.trs n'' ms = SOME ms'') /\ - m.pc ms'' NOTIN ls1 UNION ls2``, + !ms ls ms' n. + ~(weak_rel_steps m ms ls ms' n) ==> + (n > 0) ==> + (FUNPOW_OPT m.trs n ms = SOME ms') ==> + (m.pc ms' IN ls) ==> + ?n' ms''. + n' < n /\ n' > 0 /\ + FUNPOW_OPT m.trs n' ms = SOME ms'' /\ + (m.pc ms'' IN ls) /\ + (!n''. + (n'' < n' /\ n'' > 0 ==> + ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ + ~(m.pc ms''' IN ls))) + ``, cheat ); -*) -val weak_not_union_thm = prove(`` +val weak_rel_steps_intermediate_labels = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms' n. + weak_rel_steps m ms ls1 ms' n ==> + ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> + ?ms'' n'. weak_rel_steps m ms ls2 ms'' n' /\ n' < n + ``, + +REPEAT STRIP_TAC >> +fs [weak_rel_steps_def] >> +rfs [] >> +subgoal `?n' ms''. + n' < n /\ n' > 0 /\ + FUNPOW_OPT m.trs n' ms = SOME ms'' /\ + (m.pc ms'' IN (ls1 UNION ls2)) /\ + (!n''. + (n'' < n' /\ n'' > 0 ==> + ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ + ~(m.pc ms''' IN (ls1 UNION ls2))))` >- ( + irule weak_rel_steps_smallest_exists >> + fs [weak_rel_steps_def] >> + Q.EXISTS_TAC `n'` >> + REPEAT STRIP_TAC >> ( + fs [] + ) +) >> +Q.EXISTS_TAC `ms''` >> +Q.EXISTS_TAC `n''` >> +fs [] >| [ + QSPECL_X_ASSUM ``!(n':num). n' < n /\ n' > 0 ==> _`` [`n''`] >> + rfs [], + + REPEAT STRIP_TAC >> + QSPECL_X_ASSUM ``!(n'3':num). n'3' < n'' /\ n'3' > 0 ==> _`` [`n'3'`] >> + rfs [] +] +); + +val weak_rel_steps_union = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' n n'. + weak_rel_steps m ms ls1 ms' n ==> + weak_rel_steps m ms ls2 ms'' n' ==> + n' < n ==> + weak_rel_steps m ms (ls1 UNION ls2) ms'' n' + ``, + +REPEAT STRIP_TAC >> +fs [weak_rel_steps_def] >> +REPEAT STRIP_TAC >> +QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> +QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> +rfs [] >> +fs [] +); + +val weak_intermediate_labels = prove(`` !m. weak_model m ==> !ms ls1 ls2 ms'. + m.weak ms ls1 ms' ==> ~(m.weak ms (ls1 UNION ls2) ms') ==> - ~(m.weak ms ls1 ms') /\ ~(m.weak ms ls2 ms')``, + ?ms''. (m.pc ms'') IN ls2 /\ m.weak ms (ls1 UNION ls2) ms'' + ``, REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >| [ - QSPECL_X_ASSUM ``!n. - (~(n > 0) \/ FUNPOW_OPT m.trs n ms <> SOME ms' \/ - m.pc ms' NOTIN ls1 UNION ls2) \/ - ?n'. - (n' < n /\ n' > 0) /\ - !ms''. - FUNPOW_OPT m.trs n' ms <> SOME ms'' \/ - m.pc ms'' IN ls1 UNION ls2`` [`n`] >> ( - FULL_SIMP_TAC (arith_ss++pred_setLib.PRED_SET_ss) [] - ) >> - QSPECL_X_ASSUM ``!(n':num). n' < n /\ n' > 0 ==> _`` [`n'`] >> - REV_FULL_SIMP_TAC arith_ss [] >> - QSPECL_X_ASSUM ``!ms''. _`` [`ms''`] >> - +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> +QSPECL_X_ASSUM ``!n. _`` [`n`] >> +IMP_RES_TAC weak_rel_steps_intermediate_labels >> +Q.EXISTS_TAC `ms''` >> +CONJ_TAC >| [ + METIS_TAC [weak_rel_steps_label], + + METIS_TAC [weak_rel_steps_union] ] -cheat ); (* Definition of the triple *) (* Pre and post usually have conditions on execution mode and code in memory *) (* also post is usually a map that depends on the end state address *) -val weak_partial_triple_def = Define ` - weak_partial_triple m (l:'a) (ls:'a->bool) pre post = +val abstract_partial_jgmt_def = Define ` + abstract_partial_jgmt m (l:'a) (ls:'a->bool) pre post = !ms ms'. ((m.pc ms) = l) ==> pre ms ==> @@ -71,14 +166,14 @@ val weak_partial_triple_def = Define ` post ms' `; -val weak_triple_imp_partial_triple = - store_thm("weak_triple_imp_partial_triple", +val abstract_jgmt_imp_partial_triple = + store_thm("abstract_jgmt_imp_partial_triple", ``!m l ls pre post. weak_model m ==> - weak_triple m l ls pre post ==> - weak_partial_triple m l ls pre post``, + abstract_jgmt m l ls pre post ==> + abstract_partial_jgmt m l ls pre post``, -FULL_SIMP_TAC std_ss [weak_triple_def, weak_partial_triple_def] >> +FULL_SIMP_TAC std_ss [abstract_jgmt_def, abstract_partial_jgmt_def] >> REPEAT STRIP_TAC >> QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> METIS_TAC [weak_unique_thm] @@ -86,13 +181,13 @@ METIS_TAC [weak_unique_thm] val weak_partial_case_rule_thm = prove(`` !m l ls pre post C1. - weak_partial_triple m l ls (\ms. (pre ms) /\ (C1 ms)) post ==> - weak_partial_triple m l ls (\ms. (pre ms) /\ (~(C1 ms))) post ==> - weak_partial_triple m l ls pre post + abstract_partial_jgmt m l ls (\ms. (pre ms) /\ (C1 ms)) post ==> + abstract_partial_jgmt m l ls (\ms. (pre ms) /\ (~(C1 ms))) post ==> + abstract_partial_jgmt m l ls pre post ``, REPEAT STRIP_TAC >> -FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> METIS_TAC [] ); @@ -103,93 +198,39 @@ val weak_partial_weakening_rule_thm = weak_model m ==> (!ms. ((m.pc ms) = l) ==> (pre2 ms) ==> (pre1 ms)) ==> (!ms. ((m.pc ms) IN ls) ==> (post1 ms) ==> (post2 ms)) ==> - weak_partial_triple m l ls pre1 post1 ==> - weak_partial_triple m l ls pre2 post2 + abstract_partial_jgmt m l ls pre1 post1 ==> + abstract_partial_jgmt m l ls pre2 post2 ``, -SIMP_TAC std_ss [weak_partial_triple_def] >> +SIMP_TAC std_ss [abstract_partial_jgmt_def] >> REPEAT STRIP_TAC >> IMP_RES_TAC weak_pc_in_thm >> METIS_TAC [weak_pc_in_thm] ); - -(* TODO: This is introduced since negating m.weak gets weird *) -val trs_in_lblset_def = Define ` - trs_in_lblset m ms n ls = - let - ms'_opt = FUNPOW_OPT m.trs n ms - in - if IS_NONE ms'_opt - then F - else if m.pc (THE ms'_opt) IN ls - then T - else F -`; - val weak_partial_subset_rule_thm = store_thm("weak_partial_subset_rule_thm", ``!m. ! l ls1 ls2 pre post . weak_model m ==> - (!ms. ((post ms) ==> (~((m.pc ms) IN ls2)))) ==> - weak_partial_triple m l (ls1 UNION ls2) pre post ==> - weak_partial_triple m l ls1 pre post``, + (!ms. post ms ==> (~(m.pc ms IN ls2))) ==> + abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> + abstract_partial_jgmt m l ls1 pre post``, REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +rfs [abstract_partial_jgmt_def] >> REPEAT STRIP_TAC >> -QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> -REV_FULL_SIMP_TAC std_ss [] >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -(* Either execution from ms to ms' encounters ls2 along the way, or not. *) -Cases_on `?n'. n' <= n /\ n' > 0 ==> trs_in_lblset m ms n' ls2` >| [ - (* Case yes: Then there must be a first time (as in, the encounter with least amount of steps - * taken) ls2 is encountered (needs separate proof), say after n' steps in state ms''. - * So, (m.pc ms'' IN ls2) and m.weak ms (ls1 UNION ls2) ms'' (since no ls1 encountered from - * m.weak ms ls1 ms') but with - * !ms''. m.weak ms (ls1 UNION ls2) ms'' ==> post ms'' you can then derive that post ms'', which is - * contradicted by !ms. post ms ==> m.pc ms NOTIN ls2. *) - subgoal `?n''. !n'''. n''' < n'' /\ n'' > 0 ==> ~trs_in_lblset m ms n''' ls` >- ( - Q.EXISTS_TAC `n'` >> - cheat - ) >> - cheat, - - (* Case no: m.weak ms ls1 ms' can be expanded to m.weak ms (ls1 UNION ls2) ms' - * and be used with !ms''. m.weak ms (ls1 UNION ls2) ms'' ==> post ms'' to obtain - * post ms'. *) - FULL_SIMP_TAC std_ss [] >> - `?n'. - ((FUNPOW_OPT m.trs n' ms = SOME ms') /\ - m.pc ms' IN ls1 UNION ls2) /\ - !n''. - n'' < n' ==> - ?ms''. - (FUNPOW_OPT m.trs n'' ms = SOME ms'') /\ - m.pc ms'' NOTIN ls1 UNION ls2` suffices_by ( - METIS_TAC [] - ) >> - Q.EXISTS_TAC `n` >> - REPEAT STRIP_TAC >> ( - FULL_SIMP_TAC (arith_ss++pred_setLib.PRED_SET_ss) [] - ) >> - QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> - FULL_SIMP_TAC std_ss [trs_in_lblset_def, LET_DEF] >| [ - (* Contradiction: Cannot be NONE for n'' steps, then return to SOME for n steps *) - cheat, - - subgoal `?ms''. FUNPOW_OPT m.trs n'' ms = SOME ms''` >- ( - (* Contradiction: Cannot be NONE for n'' steps, then return to SOME for n steps *) - cheat - ) >> - FULL_SIMP_TAC std_ss [] >> - QSPECL_X_ASSUM ``!n'. - n' < n ==> - ?ms''. - (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ m.pc ms'' NOTIN ls1`` [`n''`] >> - REV_FULL_SIMP_TAC std_ss [] - ] -] +QSPECL_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> +rfs [] >> +Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( + fs [] +) >> +subgoal `?n. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( + METIS_TAC [weak_model_def] +) >> +IMP_RES_TAC weak_intermediate_labels >> +QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms''`] >> +rfs [] >> +METIS_TAC [] ); @@ -197,27 +238,40 @@ val weak_partial_conj_rule_thm = prove(`` !m. weak_model m ==> !l ls pre post1 post2. - weak_partial_triple m l ls pre post1 ==> - weak_partial_triple m l ls pre post2 ==> - weak_partial_triple m l ls pre (\ms. (post1 ms) /\ (post2 ms))``, + abstract_partial_jgmt m l ls pre post1 ==> + abstract_partial_jgmt m l ls pre post2 ==> + abstract_partial_jgmt m l ls pre (\ms. (post1 ms) /\ (post2 ms))``, REPEAT STRIP_TAC >> -FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> REPEAT STRIP_TAC >> METIS_TAC [weak_unique_thm] ); +(* TODO: This is introduced since negating m.weak gets weird *) +(* TODO: Still needed? *) +val trs_in_lblset_def = Define ` + trs_in_lblset m ms n ls = + let + ms'_opt = FUNPOW_OPT m.trs n ms + in + if IS_NONE ms'_opt + then F + else if m.pc (THE ms'_opt) IN ls + then T + else F +`; val weak_partial_seq_rule_thm = store_thm("weak_partial_seq_rule_thm", ``!m l ls1 ls2 pre post. weak_model m ==> - weak_partial_triple m l (ls1 UNION ls2) pre post ==> + abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> (!l1. (l1 IN ls1) ==> - (weak_partial_triple m l1 ls2 post post)) ==> - weak_partial_triple m l ls2 pre post``, + (abstract_partial_jgmt m l1 ls2 post post)) ==> + abstract_partial_jgmt m l ls2 pre post``, REPEAT STRIP_TAC >> -FULL_SIMP_TAC std_ss [weak_partial_triple_def] >> +FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> REPEAT STRIP_TAC >> QSPECL_X_ASSUM ``!ms ms'. (m.pc ms = l) ==> @@ -252,9 +306,9 @@ Cases_on `?n'. n' <= n /\ n' > 0 ==> trs_in_lblset m ms n' ls1` >| [ val weak_partial_loop_contract_def = Define ` weak_partial_loop_contract m l le invariant C1 var = - (~(l IN le)) /\ - (weak_partial_triple m l ({l} UNION le) (\ms. (invariant ms) /\ (C1 ms)) - (\ms.(((m.pc ms)=l) /\ (invariant ms)))) + ((~(l IN le)) /\ + (abstract_partial_jgmt m l ({l} UNION le) (\ms. (invariant ms) /\ (C1 ms)) + (\ms.(((m.pc ms)=l) /\ (invariant ms))))) `; (* TODO: Preliminaries for proving partial loop rule *) val weak_partial_loop_rule_thm = store_thm("weak_partial_loop_rule_thm", @@ -262,8 +316,8 @@ val weak_partial_loop_rule_thm = store_thm("weak_partial_loop_rule_thm", weak_model m ==> !l le invariant C1 var post. weak_partial_loop_contract m l le invariant C1 var ==> - weak_partial_triple m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> - weak_partial_triple m l le invariant post``, + abstract_partial_jgmt m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> + abstract_partial_jgmt m l le invariant post``, cheat ); From 58f3220f068b8cc27fb88993b9bed5c3dc678b87 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 28 Apr 2022 10:04:08 +0200 Subject: [PATCH 0088/1015] Partial correctness version of unstructured Hoare logic done, apart from a few cheats --- .../abstract_hoare_logicScript.sml | 6 +- .../abstract_hoare_logic_partialScript.sml | 336 ++++++++++++++++-- 2 files changed, 305 insertions(+), 37 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index e45148e7a..905f3c4ed 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -291,9 +291,9 @@ METIS_TAC [weak_unique_thm] val loop_step_def = Define ` loop_step m ms var l le invariant C1 = let x:num = var ms in - (\ms'. (m.weak ms ({l} UNION le) ms') /\ - ((invariant ms) /\ (C1 ms)) /\ - (((m.pc ms')=l) /\ (invariant ms') /\ ((var ms') < x) /\ ((var ms') >= 0)) + (\ms'. m.weak ms ({l} UNION le) ms' /\ + (invariant ms /\ C1 ms) /\ + ((m.pc ms' = l) /\ invariant ms' /\ (var ms' < x) /\ (var ms' >= 0)) ) `; diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 54f2162c3..f8cd86dbf 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -44,6 +44,19 @@ EQ_TAC >> ( ] ); +val weak_rel_steps_imp = prove(`` + !m ms ls ms' n. + weak_model m ==> + (weak_rel_steps m ms ls ms' n ==> + m.weak ms ls ms') + ``, + +REPEAT STRIP_TAC >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +Q.EXISTS_TAC `n` >> +fs [weak_rel_steps_def] +); + val weak_rel_steps_label = prove(`` !m ms ls ms' n. weak_model m ==> @@ -54,18 +67,24 @@ val weak_rel_steps_label = prove(`` fs [weak_rel_steps_def] ); +(* If ms and ms' are not related by weak transition to ls for n transitions, + * but if taking n transitions from ms takes you to ms' with a label in ls, + * then there has to exist an ms'' and a *smallest* n' such that the label of + * ms'' is in ls. *) val weak_rel_steps_smallest_exists = prove(`` !m. weak_model m ==> !ms ls ms' n. + (* TODO: Only needed for strict inequality *) ~(weak_rel_steps m ms ls ms' n) ==> - (n > 0) ==> - (FUNPOW_OPT m.trs n ms = SOME ms') ==> - (m.pc ms' IN ls) ==> + n > 0 ==> + FUNPOW_OPT m.trs n ms = SOME ms' ==> + m.pc ms' IN ls ==> + (* TODO: Can be phrased better *) ?n' ms''. n' < n /\ n' > 0 /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ - (m.pc ms'' IN ls) /\ + m.pc ms'' IN ls /\ (!n''. (n'' < n' /\ n'' > 0 ==> ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ @@ -154,6 +173,136 @@ CONJ_TAC >| [ ] ); +val FUNPOW_ASSOC = prove(`` +!f m n x. +FUNPOW f m (FUNPOW f n x) = FUNPOW f n (FUNPOW f m x)``, + +fs [GSYM arithmeticTheory.FUNPOW_ADD] +); + +val FUNPOW_SUB = prove(`` +!f m n x. +m > n ==> +FUNPOW f (m - n) (FUNPOW f n x) = FUNPOW f m x``, + +fs [GSYM arithmeticTheory.FUNPOW_ADD] +); + +val FUNPOW_OPT_split = prove(`` +!f n n' s s' s''. +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f (n + n') s = SOME s'' ==> +FUNPOW_OPT f n' s' = SOME s''``, + +METIS_TAC [FUNPOW_ASSOC, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +); + +val FUNPOW_OPT_split2 = prove(`` +!f n' n s s'' s'. +n > n' ==> +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f n' s = SOME s'' ==> +FUNPOW_OPT f (n - n') s'' = SOME s'``, + +REPEAT STRIP_TAC >> +METIS_TAC [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +); + +val weak_rel_steps_unique = prove(`` + !m. + weak_model m ==> + !ms ls ms' ms'' n n'. + weak_rel_steps m ms ls ms' n ==> + weak_rel_steps m ms ls ms'' n' ==> + (ms' = ms'' /\ n = n') + ``, + +REPEAT STRIP_TAC >| [ + METIS_TAC [weak_rel_steps_imp, weak_unique_thm], + + fs [weak_rel_steps_def] >> + CCONTR_TAC >> + Cases_on `n < n'` >- ( + QSPECL_X_ASSUM ``!n''. _`` [`n`] >> + rfs [] + ) >> + QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls`` [`n'`] >> + rfs [] +] +); + +val weak_rel_steps_intermediate_labels2 = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' n n'. + weak_rel_steps m ms ls2 ms' n ==> + ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> + weak_rel_steps m ms (ls1 UNION ls2) ms'' n' ==> + ?n''. weak_rel_steps m ms'' ls2 ms' n'' /\ n'' < n + ``, + +REPEAT STRIP_TAC >> +subgoal `weak_rel_steps m ms (ls1 UNION ls2) ms'' n' /\ n' < n` >- ( + subgoal `?ms'' n'. weak_rel_steps m ms (ls1 UNION ls2) ms'' n' /\ n' < n` >- ( + METIS_TAC [weak_rel_steps_intermediate_labels, weak_rel_steps_union, pred_setTheory.UNION_COMM] + ) >> + METIS_TAC [weak_rel_steps_unique] +) >> +fs [] >> +fs [weak_rel_steps_def] >> +rfs [] >> ( + Q.EXISTS_TAC `n - n'` >> + subgoal `FUNPOW_OPT m.trs (n - n') ms'' = SOME ms'` >- ( + METIS_TAC [FUNPOW_OPT_split2, arithmeticTheory.GREATER_DEF] + ) >> + fs [] >> + REPEAT STRIP_TAC >> + QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n' + n'3'`] >> + subgoal `n' + n'3' < n` >- ( + fs [] + ) >> + subgoal `n' + n'3' > 0` >- ( + fs [] + ) >> + fs [] >> + Q.EXISTS_TAC `ms'3'` >> + fs [] >> + METIS_TAC [FUNPOW_OPT_split] +) +); + +val weak_rel_steps_intermediate_labels3 = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' n n'. + weak_rel_steps m ms ls1 ms' n ==> + weak_rel_steps m ms (ls2 UNION ls1) ms'' n' ==> + n' < n ==> + m.pc ms'' IN ls2 + ``, + +cheat +); + +val weak_intermediate_labels2 = prove(`` + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms''. + m.weak ms ls2 ms' ==> + ~(m.weak ms (ls1 UNION ls2) ms') ==> + m.weak ms (ls1 UNION ls2) ms'' ==> + m.weak ms'' ls2 ms' + ``, + +REPEAT STRIP_TAC >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> +METIS_TAC [weak_rel_steps_intermediate_labels2] +); + (* Definition of the triple *) (* Pre and post usually have conditions on execution mode and code in memory *) (* also post is usually a map that depends on the end state address *) @@ -204,7 +353,6 @@ val weak_partial_weakening_rule_thm = SIMP_TAC std_ss [abstract_partial_jgmt_def] >> REPEAT STRIP_TAC >> -IMP_RES_TAC weak_pc_in_thm >> METIS_TAC [weak_pc_in_thm] ); @@ -278,48 +426,168 @@ QSPECL_X_ASSUM ``!ms ms'. pre ms ==> m.weak ms (ls1 UNION ls2) ms' ==> post ms'`` [`ms`] >> -REV_FULL_SIMP_TAC std_ss [] >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -(* Case split on whether ls1 was visited before ms'. *) -Cases_on `?n'. n' <= n /\ n' > 0 ==> trs_in_lblset m ms n' ls1` >| [ - (* Case yes: Then there must be a first time (as in, the encounter with least amount of steps - * taken) ls1 is encountered (needs separate proof), say after n' steps in state ms''. - * So, (m.pc ms'' IN ls1) and m.weak ms (ls1 UNION ls2) ms'' (since no ls2 encountered from - * m.weak ms ls2 ms') but with - * !l1. - l1 IN ls1 ==> - !ms ms'. - (m.pc ms = l1) ==> - post ms ==> - m.weak ms ls2 ms' ==> - post ms' you can then derive that post ms'. *) - cheat, - - (* Case no: m.weak ms ls1 ms' can be expanded to m.weak ms (ls1 UNION ls2) ms' - * and be used with !ms''. m.weak ms (ls1 UNION ls2) ms'' ==> post ms'' to obtain - * post ms'. *) - cheat -] +rfs [] >> +subgoal `(m.pc ms') IN ls2` >- ( + METIS_TAC [weak_pc_in_thm] +) >> +Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( + METIS_TAC [] +) >> +subgoal `?ms''. m.pc ms'' IN ls1 /\ m.weak ms (ls2 UNION ls1) ms''` >- ( + METIS_TAC [weak_intermediate_labels, pred_setTheory.UNION_COMM] +) >> +QSPECL_X_ASSUM ``!l1. l1 IN ls1 ==> _`` [`m.pc ms''`] >> +rfs [] >> +QSPECL_X_ASSUM ``!ms ms'. _`` [`ms''`, `ms'`] >> +rfs [] >> +subgoal `post ms''` >- ( + METIS_TAC [pred_setTheory.UNION_COMM] +) >> +METIS_TAC [pred_setTheory.UNION_COMM, weak_intermediate_labels2] ); +val weak_rel_steps_list_states = prove(`` +!m ms l ls ms' n. + weak_model m ==> + weak_rel_steps m ms ls ms' n ==> + ?ms_list. + (LENGTH ms_list = 0 ==> weak_rel_steps m ms ({l} UNION ls) ms' n) /\ + (LENGTH ms_list > 0 ==> + !i. (?n'. weak_rel_steps m ms ({l} UNION ls) (HD ms_list) n' /\ n' < n /\ n' > 0) /\ + (i < ((LENGTH ms_list) - 1) ==> ?n'. + weak_rel_steps m (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list) n' /\ n' < n /\ n' > 0) /\ + ?n''. weak_rel_steps m (EL ((LENGTH ms_list) - 1) ms_list) ({l} UNION ls) ms' n'' /\ n'' > 0) +``, + +cheat +); + +(* OLD +val weak_list_states = prove(`` +!m ms l ls ms'. + weak_model m ==> + weak ms ls ms' ==> + ?ms_list. + (LENGTH ms_list = 0 ==> m.weak ms ({l} UNION ls) ms') /\ + (LENGTH ms_list > 0 ==> + !i. (i = 0 ==> m.weak ms ({l} UNION ls) (EL i ms_list) /\ + m.weak (EL i ms_list) ({l} UNION ls) ms') /\ + (i > 0 /\ i < ((LENGTH ms_list) - 1) ==> + m.weak (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list)) /\ + m.weak (EL ((LENGTH ms_list) - 1) ms_list) ({l} UNION ls) ms') +``, + +cheat +); +*) val weak_partial_loop_contract_def = Define ` - weak_partial_loop_contract m l le invariant C1 var = - ((~(l IN le)) /\ - (abstract_partial_jgmt m l ({l} UNION le) (\ms. (invariant ms) /\ (C1 ms)) - (\ms.(((m.pc ms)=l) /\ (invariant ms))))) + weak_partial_loop_contract m l le invariant C1 = + (l NOTIN le /\ + abstract_partial_jgmt m l ({l} UNION le) (\ms. invariant ms /\ C1 ms) + (\ms. m.pc ms = l /\ invariant ms)) `; (* TODO: Preliminaries for proving partial loop rule *) val weak_partial_loop_rule_thm = store_thm("weak_partial_loop_rule_thm", ``!m. weak_model m ==> !l le invariant C1 var post. - weak_partial_loop_contract m l le invariant C1 var ==> - abstract_partial_jgmt m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> + weak_partial_loop_contract m l le invariant C1 ==> + abstract_partial_jgmt m l le (\ms. invariant ms /\ ~(C1 ms)) post ==> abstract_partial_jgmt m l le invariant post``, -cheat +REPEAT STRIP_TAC >> +fs [abstract_partial_jgmt_def, weak_partial_loop_contract_def] >> +REPEAT STRIP_TAC >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> +IMP_RES_TAC weak_rel_steps_list_states >> +QSPECL_X_ASSUM ``!l. ?ms_list. _`` [`l`] >> +fs [] >> +Cases_on `ms_list = []` >- ( + fs [] >> + QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> + QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> + rfs [] >> + Cases_on `C1 ms` >| [ + METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp], + + METIS_TAC [] + ] +) >> +subgoal `LENGTH ms_list > 0` >- ( + fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] +) >> +fs [] >> +Cases_on `~C1 ms` >- ( + cheat +) >> +fs [] >> +(* TODO: Fill this out *) +subgoal `!i. i < LENGTH ms_list ==> m.pc (EL i ms_list) = l /\ invariant (EL i ms_list)` >- ( + Induct_on `i` >- ( + REPEAT STRIP_TAC >> ( + fs [] >> + QSPECL_X_ASSUM ``!i. _`` [`0`] >> + fs [] >> + METIS_TAC [weak_rel_steps_intermediate_labels3, pred_setTheory.IN_SING] + ) + ) >> + REPEAT STRIP_TAC >> ( + fs [] + ) >> ( + QSPECL_X_ASSUM ``!i. _`` [`i`] >> + fs [] >> + rfs [] >> + QSPECL_X_ASSUM ``!ms ms'. _`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> + QSPECL_X_ASSUM ``!ms ms'. _`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> + rfs [] >> + subgoal `!i. i < LENGTH ms_list - 1 ==> C1 (EL i ms_list)` >- ( + cheat + ) >> + QSPECL_X_ASSUM ``!i. _`` [`i`] >> + rfs [] >> + fs [] >> + `?n. weak_rel_steps m (EL i ms_list) ({l} UNION le) (EL (SUC i) ms_list) n` suffices_by ( + fs [] + ) >> + Q.EXISTS_TAC `n'3'` >> + fs [arithmeticTheory.SUC_ONE_ADD] + ) +) >> +QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> +QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> +subgoal `MEM (EL (LENGTH ms_list − 1) ms_list) ms_list` >- ( + subgoal `LENGTH ms_list − 1 < LENGTH ms_list` >- ( + fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) >> + METIS_TAC [rich_listTheory.EL_MEM] +) >> +rfs [] >> +Cases_on `C1 (EL (LENGTH ms_list − 1) ms_list)` >| [ + fs [] >> + QSPECL_X_ASSUM ``!i. _`` [`LENGTH ms_list − 1`] >> + fs [] >> + METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp], + + subgoal `m.pc ms' <> l` >- ( + METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp] + ) >> + fs [] >> + QSPECL_X_ASSUM ``!i. A /\ B`` [`LENGTH ms_list − 1`] >> + fs [] >> + `?n. weak_rel_steps m (EL (LENGTH ms_list − 1) ms_list) le ms' n` suffices_by ( + fs [] + ) >> + subgoal `m.weak (EL (LENGTH ms_list − 1) ms_list) ({l} UNION le) ms'` >- ( + METIS_TAC [weak_rel_steps_imp] + ) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_rel_steps_equiv thm)]) >> + irule weak_union_pc_not_in_thm >> + fs [] >> + Q.EXISTS_TAC `{l}` >> + fs [pred_setTheory.UNION_COMM] +] ); val _ = export_theory(); From 9d96488c24edc198d3be4498e86d4e55335f610c Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 28 Apr 2022 16:02:39 +0200 Subject: [PATCH 0089/1015] Completed partial correctness version of unstructured Hoare logic other than cheats in weak_rel_steps_list_states and weak_rel_steps_smallest_exists --- .../abstract_hoare_logicScript.sml | 2 +- .../abstract_hoare_logic_partialScript.sml | 149 +++++++++--------- 2 files changed, 75 insertions(+), 76 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index 905f3c4ed..f2dcd3303 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -88,7 +88,7 @@ Cases_on `n > n'` >- ( FULL_SIMP_TAC arith_ss [] ); -val weak_union_thm = prove(`` +val weak_union_thm = store_thm("weak_union_thm",`` !m. weak_model m ==> !ms ls1 ls2 ms'. diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index f8cd86dbf..31760a41f 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -285,7 +285,12 @@ val weak_rel_steps_intermediate_labels3 = prove(`` m.pc ms'' IN ls2 ``, -cheat +REPEAT STRIP_TAC >> +fs [weak_rel_steps_def] >> +QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> +rfs [] ); val weak_intermediate_labels2 = prove(`` @@ -396,19 +401,6 @@ REPEAT STRIP_TAC >> METIS_TAC [weak_unique_thm] ); -(* TODO: This is introduced since negating m.weak gets weird *) -(* TODO: Still needed? *) -val trs_in_lblset_def = Define ` - trs_in_lblset m ms n ls = - let - ms'_opt = FUNPOW_OPT m.trs n ms - in - if IS_NONE ms'_opt - then F - else if m.pc (THE ms'_opt) IN ls - then T - else F -`; val weak_partial_seq_rule_thm = store_thm("weak_partial_seq_rule_thm", ``!m l ls1 ls2 pre post. @@ -452,35 +444,20 @@ val weak_rel_steps_list_states = prove(`` weak_model m ==> weak_rel_steps m ms ls ms' n ==> ?ms_list. + (!i. m.pc (EL i ms_list) = l) /\ (LENGTH ms_list = 0 ==> weak_rel_steps m ms ({l} UNION ls) ms' n) /\ (LENGTH ms_list > 0 ==> - !i. (?n'. weak_rel_steps m ms ({l} UNION ls) (HD ms_list) n' /\ n' < n /\ n' > 0) /\ - (i < ((LENGTH ms_list) - 1) ==> ?n'. - weak_rel_steps m (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list) n' /\ n' < n /\ n' > 0) /\ - ?n''. weak_rel_steps m (EL ((LENGTH ms_list) - 1) ms_list) ({l} UNION ls) ms' n'' /\ n'' > 0) -``, + (?n'. weak_rel_steps m ms ({l} UNION ls) (HD ms_list) n' /\ + weak_rel_steps m (HD ms_list) ls ms' (n - n') /\ n' < n /\ n' > 0) /\ + (?n''. weak_rel_steps m (EL ((LENGTH ms_list) - 1) ms_list) ({l} UNION ls) ms' n'' /\ n'' > 0) /\ + !i. (i < ((LENGTH ms_list) - 1) ==> ?n' n''. + weak_rel_steps m (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list) n' /\ + weak_rel_steps m (EL (i+1) ms_list) ls ms' n'' /\ n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0)) -cheat -); - -(* OLD -val weak_list_states = prove(`` -!m ms l ls ms'. - weak_model m ==> - weak ms ls ms' ==> - ?ms_list. - (LENGTH ms_list = 0 ==> m.weak ms ({l} UNION ls) ms') /\ - (LENGTH ms_list > 0 ==> - !i. (i = 0 ==> m.weak ms ({l} UNION ls) (EL i ms_list) /\ - m.weak (EL i ms_list) ({l} UNION ls) ms') /\ - (i > 0 /\ i < ((LENGTH ms_list) - 1) ==> - m.weak (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list)) /\ - m.weak (EL ((LENGTH ms_list) - 1) ms_list) ({l} UNION ls) ms') ``, cheat ); -*) val weak_partial_loop_contract_def = Define ` weak_partial_loop_contract m l le invariant C1 = @@ -520,40 +497,78 @@ subgoal `LENGTH ms_list > 0` >- ( ) >> fs [] >> Cases_on `~C1 ms` >- ( - cheat + METIS_TAC [] ) >> fs [] >> -(* TODO: Fill this out *) -subgoal `!i. i < LENGTH ms_list ==> m.pc (EL i ms_list) = l /\ invariant (EL i ms_list)` >- ( +subgoal `m.pc ms' <> l` >- ( + METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp] +) >> +subgoal `!i. i < LENGTH ms_list ==> + (invariant (EL i ms_list) \/ post ms') /\ + (C1 (EL i ms_list) \/ (~C1 (EL i ms_list) /\ post ms'))` >- ( Induct_on `i` >- ( - REPEAT STRIP_TAC >> ( - fs [] >> - QSPECL_X_ASSUM ``!i. _`` [`0`] >> + fs [] >> + QSPECL_X_ASSUM ``!i. _`` [`0`] >> + subgoal `invariant (EL 0 ms_list)` >- ( fs [] >> METIS_TAC [weak_rel_steps_intermediate_labels3, pred_setTheory.IN_SING] - ) + ) >> + fs [] >> + Cases_on `C1 (HD ms_list)` >> ( + fs [] + ) >> + PAT_X_ASSUM ``!ms ms'. _`` (fn thm => irule thm) >> + Q.EXISTS_TAC `HD ms_list` >> + fs [] >> + METIS_TAC [] ) >> REPEAT STRIP_TAC >> ( fs [] - ) >> ( - QSPECL_X_ASSUM ``!i. _`` [`i`] >> + ) >| [ + QSPECL_X_ASSUM ``!ms'' ms'3'. + m.pc ms'' = l ==> + invariant ms'' /\ C1 ms'' ==> + (?n. weak_rel_steps m ms'' ({l} UNION le) ms'3' n) ==> + m.pc ms'3' = l /\ invariant ms'3'`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> + QSPECL_X_ASSUM ``!i. m.pc (EL i ms_list) = l`` [`i`] >> fs [] >> rfs [] >> - QSPECL_X_ASSUM ``!ms ms'. _`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> - QSPECL_X_ASSUM ``!ms ms'. _`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> - rfs [] >> - subgoal `!i. i < LENGTH ms_list - 1 ==> C1 (EL i ms_list)` >- ( - cheat - ) >> QSPECL_X_ASSUM ``!i. _`` [`i`] >> rfs [] >> - fs [] >> `?n. weak_rel_steps m (EL i ms_list) ({l} UNION le) (EL (SUC i) ms_list) n` suffices_by ( fs [] ) >> Q.EXISTS_TAC `n'3'` >> - fs [arithmeticTheory.SUC_ONE_ADD] - ) + fs [arithmeticTheory.SUC_ONE_ADD], + + Cases_on `C1 (EL (SUC i) ms_list)` >> ( + fs [] + ) >> + subgoal `invariant (EL (SUC i) ms_list)` >- ( + QSPECL_X_ASSUM ``!i. _`` [`i`] >> + QSPECL_X_ASSUM ``!i. _`` [`i`] >> + rfs [arithmeticTheory.SUC_ONE_ADD] >> + METIS_TAC [] + ) >> + PAT_X_ASSUM ``!ms ms'. _`` (fn thm => irule thm) >> + QSPECL_X_ASSUM ``!i. _`` [`i`] >> + Cases_on `SUC i = LENGTH ms_list - 1` >- ( + (* SUC i is last in ms_list *) + QSPECL_X_ASSUM ``!i. _`` [`SUC i`] >> + Q.EXISTS_TAC `EL (SUC i) ms_list` >> + fs [] >> + rfs [] >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_rel_steps_equiv thm)]) >> + METIS_TAC [weak_union_thm, pred_setTheory.IN_SING, weak_rel_steps_equiv] + ) >> + subgoal `SUC i < LENGTH ms_list - 1` >- ( + fs [] + ) >> + fs [] >> + Q.EXISTS_TAC `EL (SUC i) ms_list` >> + fs [arithmeticTheory.SUC_ONE_ADD] >> + METIS_TAC [] + ] ) >> QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> @@ -564,30 +579,14 @@ subgoal `MEM (EL (LENGTH ms_list − 1) ms_list) ms_list` >- ( METIS_TAC [rich_listTheory.EL_MEM] ) >> rfs [] >> -Cases_on `C1 (EL (LENGTH ms_list − 1) ms_list)` >| [ +Cases_on `C1 (EL (LENGTH ms_list − 1) ms_list)` >> ( fs [] >> QSPECL_X_ASSUM ``!i. _`` [`LENGTH ms_list − 1`] >> + QSPECL_X_ASSUM ``!i. _`` [`LENGTH ms_list − 1`] >> fs [] >> - METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp], - - subgoal `m.pc ms' <> l` >- ( - METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp] - ) >> - fs [] >> - QSPECL_X_ASSUM ``!i. A /\ B`` [`LENGTH ms_list − 1`] >> - fs [] >> - `?n. weak_rel_steps m (EL (LENGTH ms_list − 1) ms_list) le ms' n` suffices_by ( - fs [] - ) >> - subgoal `m.weak (EL (LENGTH ms_list − 1) ms_list) ({l} UNION le) ms'` >- ( - METIS_TAC [weak_rel_steps_imp] - ) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_rel_steps_equiv thm)]) >> - irule weak_union_pc_not_in_thm >> - fs [] >> - Q.EXISTS_TAC `{l}` >> - fs [pred_setTheory.UNION_COMM] -] + rfs [] >> + fs [] +) ); val _ = export_theory(); From a1ba7b359572bbd7b2e1a295575e15aee5deee79 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 2 May 2022 11:20:40 +0200 Subject: [PATCH 0090/1015] Further lemmatization of partial correctness version of L_A --- .../abstract_hoare_logic_partialScript.sml | 239 +++++++++++++++++- 1 file changed, 232 insertions(+), 7 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 31760a41f..3bed2748a 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -67,6 +67,102 @@ val weak_rel_steps_label = prove(`` fs [weak_rel_steps_def] ); +(* Returns a list of n successive applications of f on s *) +val FUNPOW_OPT_LIST_def = Define ` + (FUNPOW_OPT_LIST f 0 s = SOME []) /\ + (FUNPOW_OPT_LIST f (SUC n) s = + case f s of + | SOME res_hd => + (case FUNPOW_OPT_LIST f n res_hd of + | SOME res_tl => SOME (res_hd::res_tl) + | NONE => NONE) + | NONE => NONE)`; + +val FUNPOW_OPT_LIST_0 = prove(`` +!f res x l. +FUNPOW_OPT_LIST f 1 x = SOME l ==> +f x = SOME res ==> +l = [res] +``, + +REPEAT STRIP_TAC >> +FULL_SIMP_TAC pure_ss [arithmeticTheory.ONE, FUNPOW_OPT_LIST_def] >> +fs [] +); + +val FUNPOW_OPT_LIST_EL_SOME = prove(`` +!f n n' x l. +FUNPOW_OPT_LIST f n x = SOME l ==> +n' < n ==> +n' > 0 ==> +?x'. FUNPOW_OPT f n' x = SOME x' +``, + +cheat +); + +val FUNPOW_OPT_LIST_EXISTS = prove(`` +!f n n' x x'. +FUNPOW_OPT f n x = SOME x' ==> +n' <= n ==> +n' > 0 ==> +?l. FUNPOW_OPT_LIST f n x = SOME l +``, + +cheat +); + +val FUNPOW_OPT_LIST_INDEX_FIND = prove(`` +!f P n x l i x'. +FUNPOW_OPT_LIST f n x = SOME l ==> +INDEX_FIND 0 P l = SOME (i, x') ==> +FUNPOW_OPT f (SUC i) x = SOME x' +``, + +cheat +); + +val FUNPOW_OPT_LIST_EL = prove(`` +!f n n' x x' l. +FUNPOW_OPT_LIST f n x = SOME l ==> +n' <= n ==> +n' > 0 ==> +FUNPOW_OPT f n' x = SOME x' ==> +(EL (PRE n') l) = x' +``, + +cheat +); + +val FUNPOW_OPT_LIST_LENGTH = prove(`` +!f n x l. +FUNPOW_OPT_LIST f n x = SOME l ==> +LENGTH l = n +``, + +cheat +); + +val INDEX_FIND_MEM = prove(`` +!P l x. +P x ==> +MEM x l ==> +?i x'. INDEX_FIND 0 P l = SOME (i, x') +``, + +cheat +); + +val FILTER_MEM = prove(`` +!P l l' x. +FILTER P l = l' ==> +MEM x l' ==> +P x +``, + +cheat +); + (* If ms and ms' are not related by weak transition to ls for n transitions, * but if taking n transitions from ms takes you to ms' with a label in ls, * then there has to exist an ms'' and a *smallest* n' such that the label of @@ -75,12 +171,10 @@ val weak_rel_steps_smallest_exists = prove(`` !m. weak_model m ==> !ms ls ms' n. - (* TODO: Only needed for strict inequality *) ~(weak_rel_steps m ms ls ms' n) ==> n > 0 ==> FUNPOW_OPT m.trs n ms = SOME ms' ==> m.pc ms' IN ls ==> - (* TODO: Can be phrased better *) ?n' ms''. n' < n /\ n' > 0 /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ @@ -91,7 +185,74 @@ val weak_rel_steps_smallest_exists = prove(`` ~(m.pc ms''' IN ls))) ``, -cheat +REPEAT STRIP_TAC >> +fs [weak_rel_steps_def] >> +subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( + irule FUNPOW_OPT_LIST_EXISTS >> + fs [] >> + Q.EXISTS_TAC `n'` >> + fs [] +) >> +subgoal `?i ms''. INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( + (* OK: There is at least ms', possibly some earlier encounter of ls *) + irule INDEX_FIND_MEM >> + Q.EXISTS_TAC `ms'` >> + fs [listTheory.MEM_EL] >> + Q.EXISTS_TAC `PRE n` >> + CONJ_TAC >| [ + IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> + fs [], + + REWRITE_TAC [Once EQ_SYM_EQ] >> + irule FUNPOW_OPT_LIST_EL >> + fs [] >> + Q.EXISTS_TAC `m.trs` >> + Q.EXISTS_TAC `n` >> + Q.EXISTS_TAC `ms` >> + fs [] + ] +) >> +Q.EXISTS_TAC `SUC i` >> +Q.EXISTS_TAC `ms''` >> +fs [] >> +subgoal `?ms'''. FUNPOW_OPT m.trs n' ms = SOME ms'''` >- ( + METIS_TAC [FUNPOW_OPT_prev_EXISTS] +) >> +REPEAT STRIP_TAC >| [ + (* SUC i < n since i must be at least n' - 1, since INDEX_FIND at least must have found ms''', + * if not any earlier encounter *) + fs [INDEX_FIND_EQ_SOME_0] >> + Cases_on `(PRE n') < i` >| [ + (* Contradiction: ms''' occurs earlier than the first encounter of ls found by INDEX_FIND *) + subgoal `m.pc (EL (PRE n') ms_list) NOTIN ls` >- ( + fs [] + ) >> + subgoal `(EL (PRE n') ms_list) = ms'''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + ) >> + fs [], + + fs [] + ], + + METIS_TAC [FUNPOW_OPT_LIST_INDEX_FIND], + + fs [INDEX_FIND_EQ_SOME], + + subgoal `n'' < n` >- ( + fs [INDEX_FIND_EQ_SOME_0] >> + IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> + fs [] + ) >> + subgoal `?ms''''. FUNPOW_OPT m.trs n'' ms = SOME ms''''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL_SOME] + ) >> + subgoal `(EL (PRE n'') ms_list) = ms''''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + ) >> + fs [INDEX_FIND_EQ_SOME_0] >> + rw [] +] ); val weak_rel_steps_intermediate_labels = prove(`` @@ -443,8 +604,9 @@ val weak_rel_steps_list_states = prove(`` !m ms l ls ms' n. weak_model m ==> weak_rel_steps m ms ls ms' n ==> + l NOTIN ls ==> ?ms_list. - (!i. m.pc (EL i ms_list) = l) /\ + (!i. i < LENGTH ms_list ==> m.pc (EL i ms_list) = l) /\ (LENGTH ms_list = 0 ==> weak_rel_steps m ms ({l} UNION ls) ms' n) /\ (LENGTH ms_list > 0 ==> (?n'. weak_rel_steps m ms ({l} UNION ls) (HD ms_list) n' /\ @@ -456,7 +618,70 @@ val weak_rel_steps_list_states = prove(`` ``, -cheat +REPEAT STRIP_TAC >> +subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( + (* OK: Contradicts weak_rel_steps m ms ls ms' n otherwise *) + fs [weak_rel_steps_def] >> + irule FUNPOW_OPT_LIST_EXISTS >> + fs [] >> + Q.EXISTS_TAC `n` >> + fs [] +) >> +Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> +REPEAT STRIP_TAC >| [ + (* OK: Element in filtered list obeys filter property *) + subgoal `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list))` >- ( + irule FILTER_MEM >> + Q.EXISTS_TAC `ms_list` >> + Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> + METIS_TAC [listTheory.MEM_EL] + ) >> + fs [], + + (* OK: If filtered list is empty, l can be inserted in ending label set *) + fs [weak_rel_steps_def] >> + REPEAT STRIP_TAC >> + subgoal `?ms''. FUNPOW_OPT m.trs n' ms = SOME ms''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL_SOME] + ) >> + fs [listTheory.FILTER_EQ_NIL] >> + subgoal `EL (PRE n') ms_list = ms''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + ) >> + fs [listTheory.EVERY_EL] >> + QSPECL_X_ASSUM ``!n. _`` [`PRE n'`] >> + QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> + fs [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> + rfs [], + + (* OK: First encounter of l is reached when filtered list is non-empty, + * also weak transition can proceed from there directly to ending label set *) + subgoal `?ms''. ms'' = EL 0 (FILTER (\ms. m.pc ms = l) ms_list)` >- ( + cheat + ) >> + (* Note: last state in ms_list can't be at label l *) + subgoal `?i. ms'' = EL i ms_list /\ i < (PRE n)` >- ( + cheat + ) >> + Q.EXISTS_TAC `SUC i` >> + fs [] >> + REPEAT STRIP_TAC >| [ + (* OK *) + cheat, + + (* OK *) + cheat + ], + + (* OK: Last element in filtered list can perform weak transition with ending + * label set ({l} UNION ls) and reach ms' *) + cheat, + + (* Inductive case for weak transition with ending label set ({l} UNION ls) + * between elements of the list. Should also be OK *) + cheat +] ); val weak_partial_loop_contract_def = Define ` @@ -479,7 +704,7 @@ fs [abstract_partial_jgmt_def, weak_partial_loop_contract_def] >> REPEAT STRIP_TAC >> PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> IMP_RES_TAC weak_rel_steps_list_states >> -QSPECL_X_ASSUM ``!l. ?ms_list. _`` [`l`] >> +(* QSPECL_X_ASSUM ``!l. ?ms_list. _`` [`l`] >> *) fs [] >> Cases_on `ms_list = []` >- ( fs [] >> @@ -530,7 +755,7 @@ subgoal `!i. i < LENGTH ms_list ==> invariant ms'' /\ C1 ms'' ==> (?n. weak_rel_steps m ms'' ({l} UNION le) ms'3' n) ==> m.pc ms'3' = l /\ invariant ms'3'`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> - QSPECL_X_ASSUM ``!i. m.pc (EL i ms_list) = l`` [`i`] >> + QSPECL_X_ASSUM ``!i. i < LENGTH ms_list ==> m.pc (EL i ms_list) = l`` [`i`] >> fs [] >> rfs [] >> QSPECL_X_ASSUM ``!i. _`` [`i`] >> From a96a73f9ca6809c6eadc1f5e87a2a83cc26a2f76 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 5 May 2022 15:37:04 +0200 Subject: [PATCH 0091/1015] Updates to dev_bin_hoare_partial --- .../abstract_hoare_logic_partialScript.sml | 726 +++++++++++++++++- 1 file changed, 685 insertions(+), 41 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 3bed2748a..35d20bdf4 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -68,8 +68,9 @@ fs [weak_rel_steps_def] ); (* Returns a list of n successive applications of f on s *) +(* Hard for proofs? val FUNPOW_OPT_LIST_def = Define ` - (FUNPOW_OPT_LIST f 0 s = SOME []) /\ + (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ (FUNPOW_OPT_LIST f (SUC n) s = case f s of | SOME res_hd => @@ -77,70 +78,685 @@ val FUNPOW_OPT_LIST_def = Define ` | SOME res_tl => SOME (res_hd::res_tl) | NONE => NONE) | NONE => NONE)`; +*) + +(* Head-recursive version (nicer for most proofs) *) +val FUNPOW_OPT_LIST_def = Define ` + (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ + (FUNPOW_OPT_LIST f (SUC n) s = + case FUNPOW_OPT_LIST f n s of + | SOME res_prefix => + (case f (LAST res_prefix) of + | SOME res_last => SOME (SNOC res_last res_prefix) + | NONE => NONE) + | NONE => NONE)`; + +(* TODO: Split up in two theorems, one specific for FUNPOW_OPT equivalence? *) +val FUNPOW_OPT_LIST_EQ_SOME = prove(`` +!f n s l. +FUNPOW_OPT_LIST f n s = SOME l <=> +LENGTH l = (SUC n) /\ +FUNPOW_OPT f n s = SOME (LAST l) /\ +(!n'. n' <= n ==> FUNPOW_OPT f n' s = SOME (EL n' l)) /\ +!i. (SUC i) < LENGTH l ==> +f (EL i l) = SOME (EL (SUC i) l) +``, + +cheat +); + +val FUNPOW_OPT_LIST_EQ_NONE = prove(`` +!f n s. +FUNPOW_OPT_LIST f n s = NONE <=> +?n'. n' <= n /\ FUNPOW_OPT f n' s = NONE /\ +(* TODO: Overkill? *) +(!n''. n'' < n' ==> (FUNPOW_OPT f n'' s <> NONE)) +``, + +REPEAT STRIP_TAC >> +EQ_TAC >| [ + REPEAT STRIP_TAC >> + (* Looks OK *) + cheat, + + REPEAT STRIP_TAC >> + (* Looks OK *) + cheat +] +); + +(* +(* Tail-recursive version (useful for a few proofs) *) +val FUNPOW_OPT_LIST_tailrec_def = Define ` + (FUNPOW_OPT_LIST_tailrec f 0 s = SOME [s]) /\ + (FUNPOW_OPT_LIST_tailrec f (SUC n) s = + case f s of + | SOME res_hd => + (case FUNPOW_OPT_LIST_tailrec f n res_hd of + | SOME res_tl => SOME (res_hd::res_tl) + | NONE => NONE) + | NONE => NONE)`; + +val FUNPOW_OPT_LIST_tailrec_EQ_SOME = prove(`` +!f n s l. +FUNPOW_OPT_LIST_tailrec f n s = SOME l <=> +LENGTH l = (SUC n) /\ +FUNPOW_OPT f n s = SOME (LAST l) /\ +(!n'. n' <= n ==> FUNPOW_OPT f n' s = SOME (EL n' l)) /\ +!i. (SUC i) < LENGTH l ==> +f (EL i l) = SOME (EL (SUC i) l) +``, + +cheat +); + +val FUNPOW_OPT_LIST_tailreq_equiv = prove(`` +!f n s. +FUNPOW_OPT_LIST f n s = FUNPOW_OPT_LIST_tailrec f n s +``, + +(* TODO: Break up into lemmata... *) +cheat + +(* +Induct_on `n` >- ( + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LIST_tailrec_def] +) >> +fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LIST_tailrec_def] >> +REPEAT STRIP_TAC >> +Cases_on `FUNPOW_OPT_LIST_tailrec f n s` >| [ + (* Case: result became NONE somewhere before last step *) + cheat, + + (* Case: result is still SOME right before last step *) + IMP_RES_TAC FUNPOW_OPT_LIST_tailrec_SOME >> + fs [] >> + (* f s could not have been NONE, since FUNPOW_OPT_LIST_tailrec f n s is SOME*) + subgoal `?x. f s = SOME x` >- ( + cheat + ) >> + fs [] >> +) >> +Cases_on `FUNPOW_OPT_LIST_tailrec f n s` >> ( + fs [] +) >> +Cases_on `f s` >> ( + fs [] +) >> + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LIST_tailrec_def] +) >> +cheat +*) +); +*) + +(* +val FUNPOW_OPT_LISTS_def = Define ` + (FUNPOW_OPT_LISTS f [] s = SOME [s]) /\ + (FUNPOW_OPT_LISTS f (h::t) s = + case FUNPOW_OPT_LISTS f t s of + | SOME res_tl => + (case f (LAST res_tl) of + | SOME res_hd => SOME (res_hd::res_tl) + | NONE => NONE) + | NONE => NONE)`; +*) val FUNPOW_OPT_LIST_0 = prove(`` -!f res x l. -FUNPOW_OPT_LIST f 1 x = SOME l ==> -f x = SOME res ==> -l = [res] +!f x. +FUNPOW_OPT_LIST f 0 x = SOME [x] +``, + +REPEAT STRIP_TAC >> +fs [FUNPOW_OPT_LIST_def] +); + +val FUNPOW_OPT_LIST_NONEMPTY = prove(`` +!f n x l. +FUNPOW_OPT_LIST f n x = SOME l ==> +l <> [] ``, REPEAT STRIP_TAC >> -FULL_SIMP_TAC pure_ss [arithmeticTheory.ONE, FUNPOW_OPT_LIST_def] >> +rw [] >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_LIST_def] +) >> +Cases_on `FUNPOW_OPT_LIST f n' x` >> ( + fs [] +) >> +Cases_on `f (LAST x')` >> ( + fs [] +) +); + +val FUNPOW_OPT_LIST_LAST = prove(`` +!f n x l_opt. +FUNPOW_OPT_LIST f n x = l_opt ==> +(case l_opt of + | SOME l => + FUNPOW_OPT f n x = SOME (LAST l) + | NONE => FUNPOW_OPT f n x = NONE) +``, + +REPEAT STRIP_TAC >> +Cases_on `l_opt` >| [ + (* TODO: Prove EQ_NONE theorem? *) + fs [FUNPOW_OPT_LIST_EQ_NONE] >> + subgoal `?n''. n = n' + n''` >- ( + Q.EXISTS_TAC `n - n'` >> + fs [] + ) >> + METIS_TAC [FUNPOW_OPT_next_n_NONE], + + (* Using EQ_SOME: *) + fs [FUNPOW_OPT_LIST_EQ_SOME] +(* OLD: + Cases_on `n` >- ( + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] >> + rw [] + ) >> + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] >> + Cases_on `FUNPOW_OPT_LIST f n' x` >> ( + fs [] + ) >> + Cases_on `f (LAST x'')` >> ( + fs [] + ) >> + fs [arithmeticTheory.FUNPOW] >> + (* TODO: Tail-recursive vs. head-recursive definitions *) + cheat +*) +] +); + +val FUNPOW_OPT_LIST_CONS = prove(`` +!f x n t. +FUNPOW_OPT_LIST f n x = SOME t ==> +((?h. f (LAST t) = SOME h /\ + FUNPOW_OPT_LIST f (SUC n) x = SOME (SNOC h t)) \/ FUNPOW_OPT_LIST f (SUC n) x = NONE) +``, + +REPEAT STRIP_TAC >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_LIST_def] +) >| [ + rw [] >> + Cases_on `f x` >> ( + fs [] + ), + + Cases_on `FUNPOW_OPT_LIST f n' x` >> ( + fs [] + ) >> + Cases_on `f (LAST x')` >> ( + fs [] + ) >> + Cases_on `f (LAST t)` >> ( + fs [] + ) +] +); + +val FUNPOW_OPT_LIST_FRONT_PRE = prove(`` +!f x n t. +FUNPOW_OPT_LIST f (SUC n) x = SOME t ==> +FUNPOW_OPT_LIST f n x = SOME (FRONT t) +``, + +REPEAT STRIP_TAC >> +fs [FUNPOW_OPT_LIST_def] >> +Cases_on `FUNPOW_OPT_LIST f n x` >> ( + fs [] +) >> +Cases_on `f (LAST x')` >> ( + fs [] +) >> +rw [listTheory.FRONT_DEF] >> +fs [rich_listTheory.FRONT_APPEND] +); + +val FUNPOW_OPT_LIST_INCR2 = prove(`` +!f x n h t. +FUNPOW_OPT_LIST f n x = SOME t ==> +LENGTH t = (SUC n) ==> +f (LAST t) = SOME h ==> +FUNPOW_OPT_LIST f (SUC n) x = SOME (SNOC h t) /\ LENGTH (SNOC h t) = (SUC (SUC n)) +``, + +REPEAT STRIP_TAC >> +fs [FUNPOW_OPT_LIST_def] +); + +(* +val FUNPOW_OPT_LISTS_LENGTH = prove(`` +!l' l f x. +FUNPOW_OPT_LISTS f l' x = SOME l ==> +LENGTH l = (SUC (LENGTH l')) +``, + +cheat +); + +val FUNPOW_OPT_LISTS_EQUIV = prove(`` +!l' l f x. +FUNPOW_OPT_LISTS f l' x = SOME l <=> +FUNPOW_OPT_LIST f (LENGTH l') x = SOME l +``, + +REPEAT STRIP_TAC >> +EQ_TAC >> ( + REPEAT STRIP_TAC +) >> +Induct_on `l` >> Induct_on `l'` >> + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LISTS_def] >> + + Cases_on `FUNPOW_OPT_LISTS f l' x` >> ( + fs [] + ) >> + Cases_on `FUNPOW_OPT_LIST f (LENGTH l') x` >> ( + fs [] + ) >> + Cases_on `f (LAST x')` >> ( + fs [] + ) >> + + Cases_on `f (LAST x'')` >> ( + fs [] + ) >> +); +*) + +val FUNPOW_OPT_LIST_LENGTH = prove(`` +!n l f x. +FUNPOW_OPT_LIST f n x = SOME l ==> +LENGTH l = (SUC n) +``, + +Induct_on `n` >- ( + fs [FUNPOW_OPT_LIST_def] +) >> +REPEAT STRIP_TAC >> +subgoal `FUNPOW_OPT_LIST f n x = SOME (FRONT l)` >- ( + METIS_TAC [FUNPOW_OPT_LIST_FRONT_PRE] +) >> +RES_TAC >> +IMP_RES_TAC FUNPOW_OPT_LIST_NONEMPTY >> +IMP_RES_TAC rich_listTheory.LENGTH_FRONT >> fs [] + +(* Using FUNPOW_OPT_LISTS: +REPEAT STRIP_TAC >> +subgoal `?l'. n = LENGTH l'` >- ( + Q.EXISTS_TAC `REPLICATE n a` >> + fs [rich_listTheory.LENGTH_REPLICATE] +) >> +fs [GSYM FUNPOW_OPT_LISTS_EQUIV] >> +METIS_TAC [FUNPOW_OPT_LISTS_LENGTH] +*) +); + +val FUNPOW_OPT_step = prove(`` +!f n x x' x''. +FUNPOW_OPT f (SUC n) x = SOME x'' ==> +f x = SOME x' ==> +FUNPOW_OPT f n x' = SOME x'' +``, + +REPEAT STRIP_TAC >> +fs [FUNPOW_OPT_REWRS] +); + +val FUNPOW_OPT_INTER = store_thm ("FUNPOW_OPT_INTER", + ``!f n n' ms ms' ms''. + (FUNPOW_OPT f n ms = SOME ms') ==> + (FUNPOW_OPT f (n'+n) ms = SOME ms'') ==> + (FUNPOW_OPT f n' ms' = SOME ms'') + ``, + +METIS_TAC [FUNPOW_OPT_def, + arithmeticTheory.FUNPOW_ADD] +); + +val FUNPOW_OPT_SUBLIST = prove(`` +!f n n' x l. +n' <= n ==> +FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> +FUNPOW_OPT_LIST f (SUC n − n') (LAST (TAKE (SUC n') l)) = SOME (DROP n' l) ==> +FUNPOW_OPT_LIST f (n − n') (LAST (TAKE (SUC (SUC n')) l)) = SOME (DROP (SUC n') l) +``, + +REPEAT STRIP_TAC >> +fs [FUNPOW_OPT_LIST_EQ_SOME] >> +REPEAT STRIP_TAC >| [ + (* OK: starting one step later but taking one step less leads to same end result *) + irule FUNPOW_OPT_step >> + Q.EXISTS_TAC `LAST (TAKE (SUC n') l)` >> + fs [] >> + STRIP_TAC >| [ + QSPECL_X_ASSUM ``!i. SUC i < LENGTH l ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> + rfs [] >> + (* OK modulo basic list operations *) + cheat, + + subgoal `EL (SUC n - n') (DROP n' l) = EL (SUC (n - n')) (DROP n' l)` >- ( + fs [arithmeticTheory.SUB_LEFT_SUC] >> + Cases_on `n = n'` >> ( + fs [] + ) + ) >> + fs [listTheory.last_drop] + ], + + (* OK: starting one step later, and then taking steps that won't let you reach the end of l + * makes you reach the associated index of l *) + irule FUNPOW_OPT_INTER >> + Q.EXISTS_TAC `x` >> + Q.EXISTS_TAC `n'` >> + rfs [] >> + STRIP_TAC >| [ + (* OK modulo basic list operations *) + cheat, + + (* OK modulo basic list operations *) + cheat + ], + + (* OK: Property should hold for element i of sublist starting from element SUC n' *) + QSPECL_X_ASSUM ``!i. SUC i < LENGTH l - n' ==> + f (EL i (DROP n' l)) = SOME (EL (SUC i) (DROP n' l))`` [`SUC i`] >> + rfs [] >> + subgoal `EL (SUC i) (DROP n' l) = EL i (DROP (SUC n') l)` >- ( + (* OK modulo basic list operations *) + cheat + ) >> + subgoal `EL (SUC (SUC i)) (DROP n' l) = EL (SUC i) (DROP (SUC n') l)` >- ( + (* OK modulo basic list operations *) + cheat + ) >> + fs [] +] +); + +val FUNPOW_OPT_LIST_APPEND = prove(`` +!f n n' x l. +n' <= n ==> +FUNPOW_OPT_LIST f n x = SOME l ==> +?l' l''. +FUNPOW_OPT_LIST f n' x = SOME l' /\ +FUNPOW_OPT_LIST f (n - n') (LAST l') = SOME l'' /\ +l' ++ (DROP 1 l'') = l +``, + +REPEAT STRIP_TAC >> +Q.EXISTS_TAC `TAKE (SUC n') l` >> +Q.EXISTS_TAC `DROP n' l` >> +REPEAT STRIP_TAC >| [ + Induct_on `n'` >- ( + STRIP_TAC >> + Cases_on `n` >- ( + fs [FUNPOW_OPT_LIST_def] >> + rw [] + ) >> +(* OLD: + (* TODO: tail-recursive vs. head-recursive definitions *) + cheat +*) + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + (* OK modulo basic list operations *) + cheat + ) >> + REPEAT STRIP_TAC >> + Q.SUBGOAL_THEN `n' ≤ n` (fn thm => fs [thm]) >- ( + fs [] + ) >> + fs [FUNPOW_OPT_LIST_def] >> + Cases_on `f (LAST (TAKE (SUC n') l))` >- ( + fs [] >> +(* OLD: + (* Cannot have been NONE, since result is SOME for greater number of steps *) + cheat +*) + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n'. + n' <= n ==> + FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> + rfs [] >> + QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> + rfs [] >> + Q.SUBGOAL_THEN `LAST (TAKE (SUC n') l) = EL n' l` (fn thm => fs [thm]) >- ( + fs [] + ) + ) >> + fs [] >> +(* OLD: + (* Requires to prove that x' is the result of transition n' + 1 *) + cheat +*) + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + subgoal `x' = EL (SUC n') l` >- ( + QSPECL_X_ASSUM ``!n'. + n' <= n ==> + FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> + rfs [] >> + QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> + rfs [] >> + (* OK modulo basic list operations *) + cheat + ) >> + (* OK modulo basic list operations *) + cheat, + + (* Start off after n' steps, take n - n' steps *) + Induct_on `n'` >- ( + STRIP_TAC >> + fs [] >> + Q.SUBGOAL_THEN `TAKE 1 l = [x]` (fn thm => fs [thm]) >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + Cases_on `n` >- ( + fs [FUNPOW_OPT_def] >> + (* OK modulo basic list operations *) + cheat + ) >> + QSPECL_X_ASSUM ``!n''. _`` [`0`] >> + fs [FUNPOW_OPT_def] >> + (* OK modulo basic list operations *) + cheat +(* OLD: + (* TODO: tail-recursive vs. head-recursive definitions *) + cheat +*) + ) + ) >> + Cases_on `n` >- ( + fs [] + ) >> + REPEAT STRIP_TAC >> + Q.SUBGOAL_THEN `n' ≤ SUC n''` (fn thm => fs [thm]) >- ( + fs [] + ) >> + (* If you take one more step, if you start one step earlier, then the result is the same as before + * with one less step dropped (from head) *) + irule FUNPOW_OPT_SUBLIST >> + fs [] >> + Q.EXISTS_TAC `x` >> + fs [], + + fs [rich_listTheory.DROP_DROP_T, arithmeticTheory.ADD1] +] ); val FUNPOW_OPT_LIST_EL_SOME = prove(`` !f n n' x l. FUNPOW_OPT_LIST f n x = SOME l ==> -n' < n ==> -n' > 0 ==> +n' <= n ==> ?x'. FUNPOW_OPT f n' x = SOME x' ``, -cheat +REPEAT STRIP_TAC >> +IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> +Q.EXISTS_TAC `LAST l'` >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] ); -val FUNPOW_OPT_LIST_EXISTS = prove(`` -!f n n' x x'. -FUNPOW_OPT f n x = SOME x' ==> -n' <= n ==> -n' > 0 ==> -?l. FUNPOW_OPT_LIST f n x = SOME l +val FUNPOW_OPT_LIST_EL_NONE = prove(`` +!f n n' x. +FUNPOW_OPT_LIST f n x = NONE ==> +(n' >= n) ==> +FUNPOW_OPT f n' x = NONE ``, -cheat +REPEAT STRIP_TAC >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] >> +subgoal `?n''. n' = n + n''` >- ( + fs [arithmeticTheory.LESS_EQUAL_ADD] +) >> +METIS_TAC [FUNPOW_OPT_next_n_NONE] ); -val FUNPOW_OPT_LIST_INDEX_FIND = prove(`` -!f P n x l i x'. -FUNPOW_OPT_LIST f n x = SOME l ==> -INDEX_FIND 0 P l = SOME (i, x') ==> -FUNPOW_OPT f (SUC i) x = SOME x' +(* TODO: Use FUNPOW_OPT_next_n_NONE instead of this *) +val FUNPOW_OPT_ADD_NONE = store_thm ("FUNPOW_OPT_ADD_NONE", + ``!f n n' ms ms'. + (FUNPOW_OPT f n ms = SOME ms') ==> + (FUNPOW_OPT f n' ms' = NONE) ==> + (FUNPOW_OPT f (n'+n) ms = NONE)``, + +METIS_TAC [FUNPOW_OPT_def, + arithmeticTheory.FUNPOW_ADD] +); + +val FUNPOW_OPT_LIST_EL_NEXT = prove(`` +!f n x x'. +FUNPOW_OPT_LIST f n x = SOME x' ==> +FUNPOW_OPT f (SUC n) x = f (LAST x') ``, +REPEAT STRIP_TAC >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] >> +Cases_on `f (LAST x')` >| [ + fs [arithmeticTheory.ADD1] >> + ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> + irule FUNPOW_OPT_ADD_NONE >> + Q.EXISTS_TAC `LAST x'` >> + fs [FUNPOW_OPT_compute], + + fs [arithmeticTheory.ADD1] >> + ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> + irule FUNPOW_OPT_ADD_thm >> + Q.EXISTS_TAC `LAST x'` >> + fs [FUNPOW_OPT_compute] +] +(* OLD: +(* TODO: tail vs. head FUNPOW_OPT *) cheat +*) +); + +val FUNPOW_OPT_LIST_NONE = prove(`` +!f n x. +FUNPOW_OPT_LIST f n x = NONE ==> +FUNPOW_OPT_LIST f (SUC n) x = NONE +``, + +fs [FUNPOW_OPT_LIST_def] +); + +val FUNPOW_OPT_LIST_EXISTS = prove(`` +!f n n' x x'. +FUNPOW_OPT f n x = SOME x' ==> +n' <= n ==> +?l. FUNPOW_OPT_LIST f n' x = SOME l +``, + +Induct_on `n` >- ( + REPEAT STRIP_TAC >> + Q.EXISTS_TAC `[x']` >> + fs [] >> + rw [] >> + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] +) >> +REPEAT STRIP_TAC >> +Cases_on `n' = SUC n` >- ( + fs [FUNPOW_OPT_LIST_def] >> + Cases_on `FUNPOW_OPT_LIST f n x` >- ( + fs [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_NONE >> + subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( + irule FUNPOW_OPT_prev_EXISTS >> + Q.EXISTS_TAC `SUC n` >> + Q.EXISTS_TAC `x'` >> + fs [] + ) >> + IMP_RES_TAC (Q.SPECL [`f`, `n`, `SUC n`, `x`] FUNPOW_OPT_LIST_EL_NONE) >> + fs [] + ) >> + Cases_on `f (LAST x'')` >- ( + fs [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_EL_NEXT >> + fs [] + ) >> + fs [] +) >> +subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( + irule FUNPOW_OPT_prev_EXISTS >> + Q.EXISTS_TAC `SUC n` >> + Q.EXISTS_TAC `x'` >> + fs [] +) >> +QSPECL_X_ASSUM ``!f n' x x'. _`` [`f`, `n'`, `x`, `x''`] >> +fs [] ); val FUNPOW_OPT_LIST_EL = prove(`` !f n n' x x' l. FUNPOW_OPT_LIST f n x = SOME l ==> n' <= n ==> -n' > 0 ==> FUNPOW_OPT f n' x = SOME x' ==> -(EL (PRE n') l) = x' +(EL n' l) = x' ``, -cheat +REPEAT STRIP_TAC >> +IMP_RES_TAC (Q.SPECL [`f`, `n`, `n'`, `x`, `l`] FUNPOW_OPT_LIST_APPEND) >> +subgoal `EL n' l = LAST l'` >- ( + rw [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> + Q.SUBGOAL_THEN `n' = PRE (LENGTH l')` (fn thm => REWRITE_TAC [thm]) >- ( + fs [] + ) >> + Q.SUBGOAL_THEN `EL (PRE (LENGTH l')) (l' ++ DROP 1 l'') = EL (PRE (LENGTH l')) l'` (fn thm => REWRITE_TAC [thm]) >- ( + irule rich_listTheory.EL_APPEND1 >> + fs [] + ) >> + irule rich_listTheory.EL_PRE_LENGTH >> + Cases_on `l'` >> ( + fs [] + ) +) >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] ); -val FUNPOW_OPT_LIST_LENGTH = prove(`` -!f n x l. +val FUNPOW_OPT_LIST_INDEX_FIND = prove(`` +!f P n x l i x'. FUNPOW_OPT_LIST f n x = SOME l ==> -LENGTH l = n +INDEX_FIND 0 P l = SOME (i, x') ==> +FUNPOW_OPT f i x = SOME x' ``, -cheat +REPEAT STRIP_TAC >> +fs [INDEX_FIND_EQ_SOME_0] >> +IMP_RES_TAC (Q.SPECL [`f`, `n`, `i`, `x`, `l`] FUNPOW_OPT_LIST_EL_SOME) >> +QSPECL_X_ASSUM ``!i. _`` [`i`] >> +IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> +rfs [] >> +fs [] >> +rfs [] >> +IMP_RES_TAC (Q.SPECL [`f`, `n`, `x`, `l`] FUNPOW_OPT_LIST_EQ_SOME) >> +QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT f n' x = SOME (EL n' l)`` [`i`] >> +rfs [] ); val INDEX_FIND_MEM = prove(`` @@ -150,7 +766,27 @@ MEM x l ==> ?i x'. INDEX_FIND 0 P l = SOME (i, x') ``, -cheat +Induct_on `l` >> ( + fs [] +) >> +REPEAT STRIP_TAC >| [ + Q.EXISTS_TAC `0` >> + Q.EXISTS_TAC `h` >> + fs [INDEX_FIND_EQ_SOME_0], + + Cases_on `P h` >| [ + Q.EXISTS_TAC `0` >> + Q.EXISTS_TAC `h` >> + fs [INDEX_FIND_EQ_SOME_0], + + RES_TAC >> + Q.EXISTS_TAC `SUC i` >> + Q.EXISTS_TAC `x'` >> + fs [listTheory.INDEX_FIND_def] >> + REWRITE_TAC [Once listTheory.INDEX_FIND_add] >> + fs [] + ] +] ); val FILTER_MEM = prove(`` @@ -160,7 +796,8 @@ MEM x l' ==> P x ``, -cheat +rw [] >> +fs [listTheory.MEM_FILTER] ); (* If ms and ms' are not related by weak transition to ls for n transitions, @@ -189,19 +826,20 @@ REPEAT STRIP_TAC >> fs [weak_rel_steps_def] >> subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( irule FUNPOW_OPT_LIST_EXISTS >> - fs [] >> - Q.EXISTS_TAC `n'` >> + Q.EXISTS_TAC `n` >> fs [] ) >> -subgoal `?i ms''. INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( +subgoal `?i ms''. INDEX_FIND 1 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( (* OK: There is at least ms', possibly some earlier encounter of ls *) irule INDEX_FIND_MEM >> Q.EXISTS_TAC `ms'` >> fs [listTheory.MEM_EL] >> - Q.EXISTS_TAC `PRE n` >> + Q.EXISTS_TAC `PRE n` >> (* Note: Indexing change *) CONJ_TAC >| [ IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - fs [], + fs [] >> + (* OK modulo some arithmetic *) + cheat, REWRITE_TAC [Once EQ_SYM_EQ] >> irule FUNPOW_OPT_LIST_EL >> @@ -212,27 +850,33 @@ subgoal `?i ms''. INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- fs [] ] ) >> -Q.EXISTS_TAC `SUC i` >> +Q.EXISTS_TAC `i` >> Q.EXISTS_TAC `ms''` >> fs [] >> subgoal `?ms'''. FUNPOW_OPT m.trs n' ms = SOME ms'''` >- ( METIS_TAC [FUNPOW_OPT_prev_EXISTS] ) >> REPEAT STRIP_TAC >| [ - (* SUC i < n since i must be at least n' - 1, since INDEX_FIND at least must have found ms''', + (* i < n since i must be at least n', since INDEX_FIND at least must have found ms''', * if not any earlier encounter *) fs [INDEX_FIND_EQ_SOME_0] >> - Cases_on `(PRE n') < i` >| [ + Cases_on `(SUC n') < i` >| [ (* Contradiction: ms''' occurs earlier than the first encounter of ls found by INDEX_FIND *) - subgoal `m.pc (EL (PRE n') ms_list) NOTIN ls` >- ( + subgoal `m.pc (EL n' ms_list) NOTIN ls` >- ( (* Note: Indexing change *) fs [] ) >> - subgoal `(EL (PRE n') ms_list) = ms'''` >- ( + subgoal `(EL n' ms_list) = ms'''` >- ( (* Note: Indexing change *) METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] ) >> fs [], - fs [] + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + subgoal `i <= SUC n'` >- ( + fs [] + ) >> + Cases_on `i = SUC n'` >- ( + fs [] + ) >> ], METIS_TAC [FUNPOW_OPT_LIST_INDEX_FIND], From 2f0101591c8483387e7168fcb86eb0e2548a1e58 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 5 May 2022 17:06:50 +0200 Subject: [PATCH 0092/1015] Typo + some cheats fixed in abstract_hoare_logic_partialScript.sml --- .../abstract_hoare_logic_partialScript.sml | 101 ++++++++++++++---- 1 file changed, 80 insertions(+), 21 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 35d20bdf4..0ad2e2144 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -800,6 +800,17 @@ rw [] >> fs [listTheory.MEM_FILTER] ); +val FUNPOW_OPT_LIST_FIRST = prove(`` +!f n x x' x_list. +n > 0 ==> +FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> +f x = SOME x' ==> +FUNPOW_OPT_LIST f (PRE n) x' = SOME x_list +``, + +cheat +); + (* If ms and ms' are not related by weak transition to ls for n transitions, * but if taking n transitions from ms takes you to ms' with a label in ls, * then there has to exist an ms'' and a *smallest* n' such that the label of @@ -824,12 +835,22 @@ val weak_rel_steps_smallest_exists = prove(`` REPEAT STRIP_TAC >> fs [weak_rel_steps_def] >> -subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( +subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( + IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST m.trs n' ms = SOME l`` [`n`] >> + fs [] >> + Cases_on `n` >- ( + fs [FUNPOW_OPT_LIST_def] + ) >> + (* TODO: Should be OK... *) + cheat +(* OLD irule FUNPOW_OPT_LIST_EXISTS >> Q.EXISTS_TAC `n` >> fs [] +*) ) >> -subgoal `?i ms''. INDEX_FIND 1 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( +subgoal `?i ms''. INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( (* OK: There is at least ms', possibly some earlier encounter of ls *) irule INDEX_FIND_MEM >> Q.EXISTS_TAC `ms'` >> @@ -844,13 +865,22 @@ subgoal `?i ms''. INDEX_FIND 1 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- REWRITE_TAC [Once EQ_SYM_EQ] >> irule FUNPOW_OPT_LIST_EL >> fs [] >> + subgoal `?ms''. m.trs ms = SOME ms''` >- ( + (* TODO: Should be OK... *) + cheat + ) >> Q.EXISTS_TAC `m.trs` >> - Q.EXISTS_TAC `n` >> - Q.EXISTS_TAC `ms` >> - fs [] + Q.EXISTS_TAC `PRE n` >> + Q.EXISTS_TAC `ms''` >> + fs [] >> + CONJ_TAC >| [ + cheat, + + METIS_TAC [FUNPOW_OPT_LIST_FIRST] + ] ] ) >> -Q.EXISTS_TAC `i` >> +Q.EXISTS_TAC `SUC i` >> Q.EXISTS_TAC `ms''` >> fs [] >> subgoal `?ms'''. FUNPOW_OPT m.trs n' ms = SOME ms'''` >- ( @@ -860,26 +890,23 @@ REPEAT STRIP_TAC >| [ (* i < n since i must be at least n', since INDEX_FIND at least must have found ms''', * if not any earlier encounter *) fs [INDEX_FIND_EQ_SOME_0] >> - Cases_on `(SUC n') < i` >| [ + Cases_on `n' < (SUC i)` >| [ (* Contradiction: ms''' occurs earlier than the first encounter of ls found by INDEX_FIND *) - subgoal `m.pc (EL n' ms_list) NOTIN ls` >- ( (* Note: Indexing change *) + subgoal `m.pc (EL (PRE n') ms_list) NOTIN ls` >- ( (* Note: Indexing change *) fs [] ) >> - subgoal `(EL n' ms_list) = ms'''` >- ( (* Note: Indexing change *) - METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + subgoal `(EL (PRE n') ms_list) = ms'''` >- ( (* Note: Indexing change *) + subgoal `(EL n' (ms::ms_list)) = ms'''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + ) >> + METIS_TAC [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] ) >> fs [], - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - subgoal `i <= SUC n'` >- ( - fs [] - ) >> - Cases_on `i = SUC n'` >- ( - fs [] - ) >> + fs [] ], - METIS_TAC [FUNPOW_OPT_LIST_INDEX_FIND], + fs [INDEX_FIND_EQ_SOME_0, FUNPOW_OPT_LIST_EQ_SOME], fs [INDEX_FIND_EQ_SOME], @@ -889,10 +916,20 @@ REPEAT STRIP_TAC >| [ fs [] ) >> subgoal `?ms''''. FUNPOW_OPT m.trs n'' ms = SOME ms''''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL_SOME] + METIS_TAC [FUNPOW_OPT_LIST_EL_SOME, arithmeticTheory.LESS_IMP_LESS_OR_EQ] ) >> subgoal `(EL (PRE n'') ms_list) = ms''''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + irule FUNPOW_OPT_LIST_EL >> + subgoal `?ms'''''. m.trs ms = SOME ms'''''` >- ( + (* TODO: Should be OK... *) + cheat + ) >> + Q.EXISTS_TAC `m.trs` >> + Q.EXISTS_TAC `PRE n` >> + Q.EXISTS_TAC `ms'''''` >> + fs [] >> + (* TODO: Should be OK... *) + cheat ) >> fs [INDEX_FIND_EQ_SOME_0] >> rw [] @@ -1262,6 +1299,24 @@ val weak_rel_steps_list_states = prove(`` ``, +REPEAT STRIP_TAC >> +subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( + fs [weak_rel_steps_def] >> + IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST m.trs n' ms = SOME l`` [`n`] >> + fs [] >> + Cases_on `n` >- ( + fs [FUNPOW_OPT_LIST_def] + ) >> + (* TODO: Should be OK... Need tail-recursive rewrite *) + cheat +(* OLD + irule FUNPOW_OPT_LIST_EXISTS >> + Q.EXISTS_TAC `n` >> + fs [] +*) +) >> +(* REPEAT STRIP_TAC >> subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( (* OK: Contradicts weak_rel_steps m ms ls ms' n otherwise *) @@ -1271,6 +1326,7 @@ subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( Q.EXISTS_TAC `n` >> fs [] ) >> +*) Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> REPEAT STRIP_TAC >| [ (* OK: Element in filtered list obeys filter property *) @@ -1290,7 +1346,10 @@ REPEAT STRIP_TAC >| [ ) >> fs [listTheory.FILTER_EQ_NIL] >> subgoal `EL (PRE n') ms_list = ms''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + subgoal `(EL n' (ms::ms_list)) = ms''` >- ( + METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + ) >> + METIS_TAC [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] ) >> fs [listTheory.EVERY_EL] >> QSPECL_X_ASSUM ``!n. _`` [`PRE n'`] >> From 6a25ef5677a5f2cdf713f2afeec52482bfd47ad4 Mon Sep 17 00:00:00 2001 From: ningdongywq Date: Fri, 6 May 2022 16:51:27 +0200 Subject: [PATCH 0093/1015] a new eval function with mem rw --- src/shared/bir_evalLib.sig | 3 ++- src/shared/bir_evalLib.sml | 30 +++++++++++++++++++++++++++++- 2 files changed, 31 insertions(+), 2 deletions(-) diff --git a/src/shared/bir_evalLib.sig b/src/shared/bir_evalLib.sig index d80f4e863..bf85ff3ed 100644 --- a/src/shared/bir_evalLib.sig +++ b/src/shared/bir_evalLib.sig @@ -1,6 +1,7 @@ signature bir_evalLib = sig include Abbrev; + val bir_eval_exec_n : term -> term -> int -> term list * term val bir_eval_exec : term -> term -> term list * term - + val bir_eval_mem_exec : term -> term -> term list * term end diff --git a/src/shared/bir_evalLib.sml b/src/shared/bir_evalLib.sml index 40b035040..89e089455 100644 --- a/src/shared/bir_evalLib.sml +++ b/src/shared/bir_evalLib.sml @@ -1,13 +1,26 @@ structure bir_evalLib :> bir_evalLib = struct -open HolKernel Parse boolLib bossLib bir_programSyntax pairSyntax optionSyntax; +open HolKernel Parse boolLib bossLib bir_programSyntax pairSyntax optionSyntax bir_exp_memTheory; fun cons_obs_tm ob_o (obs,st) = if is_none ob_o then (obs,st) else (dest_some ob_o :: obs, st) +fun bir_eval_exec_n prog st n = + if n = 0 then ([],st) else + let + val (_,_,status) = dest_bir_state st + in + if not (is_BST_Running status) then ([],st) else + let + val (ob_tm,st') = (dest_pair o rhs o concl) (EVAL “bir_exec_step ^prog ^st”) + in + cons_obs_tm ob_tm (bir_eval_exec_n prog st' (n-1)) + end + end + fun bir_eval_exec prog st = let val (_,_,status) = dest_bir_state st; in @@ -18,6 +31,21 @@ fun bir_eval_exec prog st = in cons_obs_tm ob_tm (bir_eval_exec prog st') end + end + +fun bir_eval_mem_exec prog st = + let val (_,_,status) = dest_bir_state st; + val mem_conv = (computeLib.RESTR_EVAL_CONV [``bir_store_in_mem``]) THENC + (REWRITE_CONV [bir_store_in_mem_REWRS]) THENC + EVAL + in + if not (is_BST_Running status) + then ([], st) + else + let val (ob_tm, st') = (dest_pair o rhs o concl) (mem_conv “bir_exec_step ^prog ^st”) + in + cons_obs_tm ob_tm (bir_eval_mem_exec prog st') + end end; end From c396a847acf9c13e6f58a265e5be2c0a76c05e45 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 6 May 2022 17:26:22 +0200 Subject: [PATCH 0094/1015] More cheats outsourced to cheated lemmata in abstract_hoare_logic_partialScript --- .../abstract_hoare_logic_partialScript.sml | 424 +++++++++++++++++- 1 file changed, 409 insertions(+), 15 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 0ad2e2144..2084bcae9 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -316,6 +316,26 @@ rw [listTheory.FRONT_DEF] >> fs [rich_listTheory.FRONT_APPEND] ); +val FUNPOW_OPT_LIST_BACK_PRE = prove(`` +!f x x' n l. +FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> +f x = SOME x' ==> +FUNPOW_OPT_LIST f n x' = SOME (TL l) +``, + +cheat +); + +val FUNPOW_OPT_LIST_BACK_INCR = prove(`` +!f x x' n t. +FUNPOW_OPT_LIST f n x' = SOME t ==> +f x = SOME x' ==> +FUNPOW_OPT_LIST f (SUC n) x = SOME (x::t) +``, + +cheat +); + val FUNPOW_OPT_LIST_INCR2 = prove(`` !f x n h t. FUNPOW_OPT_LIST f n x = SOME t ==> @@ -789,17 +809,87 @@ REPEAT STRIP_TAC >| [ ] ); +val MEM_HD = prove(`` +!l. +MEM (HD l) l +``, + +cheat +); + val FILTER_MEM = prove(`` !P l l' x. FILTER P l = l' ==> MEM x l' ==> -P x +P x /\ MEM x l ``, rw [] >> fs [listTheory.MEM_FILTER] ); +(* +val FILTER_LAST = prove(`` +!P l l' x. +LENGTH (FILTER P l) > 0 ==> +?i. EL (PRE (LENGTH (FILTER P l))) (FILTER P l) = EL i l +``, + +cheat +); +*) + +val MEM_EL_CONS = prove(`` +!n e l. +n > 0 ==> +n < SUC (LENGTH l) ==> +MEM (EL n (e::l)) l +``, + +cheat +); + +val FILTER_NOT_MEM = prove(`` +!P l l' x. +FILTER P l = l' ==> +MEM x l ==> +~MEM x l' ==> +~P x +``, + +cheat +); + +val FILTER_BEFORE = prove(`` +!P l l' i. +FILTER P l = l' ==> +EL i l = HD l' ==> +(!i'. i' < i ==> ~P (EL i l) /\ ~MEM (EL i' l) l') +``, + +cheat +); + +val FILTER_AFTER = prove(`` +!P l l' i. +FILTER P l = l' ==> +EL i l = LAST l' ==> +(!i'. i' > i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') +``, + +cheat +); + +val FILTER_ORDER = prove(`` +!P l i i' i''. +EL i' l = EL i (FILTER P l) ==> +EL i'' l = EL (SUC i) (FILTER P l) ==> +i' < i'' +``, + +cheat +); + val FUNPOW_OPT_LIST_FIRST = prove(`` !f n x x' x_list. n > 0 ==> @@ -1050,6 +1140,78 @@ REPEAT STRIP_TAC >> METIS_TAC [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] ); +val FUNPOW_OPT_split3 = prove(`` +!f n' n s s'' s'. +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f (n + n') s = SOME s'' ==> +FUNPOW_OPT f n' s' = SOME s''``, + +cheat +); + +val FUNPOW_OPT_todoname = prove(`` +!f n n' n'' P ms ms_list. +FUNPOW_OPT_LIST f n ms = SOME (ms::ms_list) ==> +FUNPOW_OPT f n'' ms = + SOME + (EL (LENGTH (FILTER P ms_list) - 1) + (FILTER P ms_list)) ==> +n' < n - n'' ==> +FUNPOW_OPT f (n' + n'') ms = SOME (EL (PRE (n' + n'')) ms_list)``, + +REPEAT STRIP_TAC >> +fs [FUNPOW_OPT_LIST_EQ_SOME] >> +irule rich_listTheory.EL_CONS >> +fs [weak_rel_steps_def] >> +cheat +); + +val weak_rel_steps_FILTER_inter = prove(`` + !m. + weak_model m ==> + !ms ls ms' i i' i'' l ms_list ms_list'. + weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> + EL i' ms_list = EL i (FILTER (\ms. m.pc ms = l) ms_list) ==> + EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> + i < LENGTH ms_list' - 1 ==> + FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> + weak_rel_steps m (EL i ms_list') ({l} UNION ls) (EL (i + 1) ms_list') (i'' - i') + ``, + +cheat +); + +val weak_rel_steps_FILTER_end = prove(`` + !m. + weak_model m ==> + !ms ls ms' i i'' l ms_list ms_list'. + weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> + FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> + i < LENGTH ms_list' - 1 ==> + EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> + weak_rel_steps m (EL (i + 1) ms_list') ls ms' (LENGTH ms_list - SUC i'') + ``, + +cheat +); + +val weak_rel_steps_FILTER_NOTIN_end = prove(`` + !m. + weak_model m ==> + !ms ls ms' n n' l ms_list ms_list'. + weak_rel_steps m ms ls ms' n ==> + l NOTIN ls ==> + FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> + EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list) = EL n' ms_list ==> + SUC n' < n + ``, + +cheat +); + val weak_rel_steps_unique = prove(`` !m. weak_model m ==> @@ -1075,6 +1237,33 @@ REPEAT STRIP_TAC >| [ ] ); +val weak_rel_steps_intermediate_start = prove(`` + !m. + weak_model m ==> + !ms ls ms' ms'' n n'. + n' < n ==> + weak_rel_steps m ms ls ms' n ==> + FUNPOW_OPT m.trs n' ms = SOME ms'' ==> + weak_rel_steps m ms'' ls ms' (n - n') + ``, + +cheat +); + +val weak_rel_steps_superset_after = prove(`` + !m. + weak_model m ==> + !ms ls ls' ms' ms'' n n'. + n' < n ==> + weak_rel_steps m ms ls ms' n ==> + weak_rel_steps m ms'' ls ms' (n - n') ==> + (!n''. n'' < (n-n') ==> (?ms'''. FUNPOW_OPT m.trs n'' ms'' = SOME ms''' /\ m.pc ms''' NOTIN ls')) ==> + weak_rel_steps m ms'' (ls' UNION ls) ms' (n - n') + ``, + +cheat +); + val weak_rel_steps_intermediate_labels2 = prove(`` !m. weak_model m ==> @@ -1280,7 +1469,8 @@ subgoal `post ms''` >- ( METIS_TAC [pred_setTheory.UNION_COMM, weak_intermediate_labels2] ); - +(* This describes the necessary characteristics of the list ms_list, which consists of + * all states where l is encountered between ms and ms'. *) val weak_rel_steps_list_states = prove(`` !m ms l ls ms' n. weak_model m ==> @@ -1296,7 +1486,6 @@ val weak_rel_steps_list_states = prove(`` !i. (i < ((LENGTH ms_list) - 1) ==> ?n' n''. weak_rel_steps m (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list) n' /\ weak_rel_steps m (EL (i+1) ms_list) ls ms' n'' /\ n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0)) - ``, REPEAT STRIP_TAC >> @@ -1308,8 +1497,22 @@ subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( Cases_on `n` >- ( fs [FUNPOW_OPT_LIST_def] ) >> - (* TODO: Should be OK... Need tail-recursive rewrite *) - cheat + subgoal `?ms''. m.trs ms = SOME ms''` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT m.trs n'' ms = SOME (EL n'' l')`` [`1`] >> + fs [FUNPOW_OPT_compute] >> + Cases_on `m.trs ms` >> ( + fs [] + ) + ) >> + subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n' ms'' = SOME ms_list` >- ( + METIS_TAC [FUNPOW_OPT_LIST_BACK_PRE] + ) >> + Q.EXISTS_TAC `ms_list` >> + (* TODO: Should be OK... + * (see also first subgoal in weak_rel_steps_smallest_exists, reuse this?) *) + IMP_RES_TAC FUNPOW_OPT_LIST_BACK_INCR >> + fs [] (* OLD irule FUNPOW_OPT_LIST_EXISTS >> Q.EXISTS_TAC `n` >> @@ -1331,8 +1534,11 @@ Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> REPEAT STRIP_TAC >| [ (* OK: Element in filtered list obeys filter property *) subgoal `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list))` >- ( + (* TODO: Silly, but it works... *) + `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list)) /\ MEM (EL i (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` suffices_by ( + fs [] + ) >> irule FILTER_MEM >> - Q.EXISTS_TAC `ms_list` >> Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> METIS_TAC [listTheory.MEM_EL] ) >> @@ -1361,29 +1567,217 @@ REPEAT STRIP_TAC >| [ (* OK: First encounter of l is reached when filtered list is non-empty, * also weak transition can proceed from there directly to ending label set *) subgoal `?ms''. ms'' = EL 0 (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - cheat + METIS_TAC [] + ) >> + (* TODO: The below is used in multiple subgoals... *) + subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( + fs [] ) >> (* Note: last state in ms_list can't be at label l *) subgoal `?i. ms'' = EL i ms_list /\ i < (PRE n)` >- ( - cheat + subgoal `?i. SOME ms'' = oEL i ms_list` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + IMP_RES_TAC FILTER_MEM >> + QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> MEM x ms_list`` [`ms''`] >> + rfs [MEM_HD] >> + fs [listTheory.MEM_EL] >> + Q.EXISTS_TAC `n'` >> + fs [listTheory.oEL_THM] + ) >> + Q.EXISTS_TAC `i` >> + fs [listTheory.oEL_EQ_EL, FUNPOW_OPT_LIST_EQ_SOME] >> + Cases_on `i = PRE n` >- ( + subgoal `m.pc ms'' = l` >- ( + IMP_RES_TAC FILTER_MEM >> + QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> (\ms. m.pc ms = l) x`` [`ms''`] >> + rfs [MEM_HD] + ) >> + fs [weak_rel_steps_def] >> + subgoal `ms'' = ms'` >- ( + `LAST (ms::ms_list) = EL (PRE n) ms_list` suffices_by ( + fs [] + ) >> + subgoal `LAST (ms::ms_list) = EL (PRE (LENGTH (ms::ms_list))) (ms::ms_list)` >- ( + irule listTheory.LAST_EL >> + fs [] + ) >> + subgoal `PRE (LENGTH (ms::ms_list)) = n` >- ( + SIMP_TAC list_ss [] >> + METIS_TAC [] + ) >> + fs [rich_listTheory.EL_CONS, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) >> + fs [] + ) >> + fs [] ) >> Q.EXISTS_TAC `SUC i` >> fs [] >> REPEAT STRIP_TAC >| [ - (* OK *) - cheat, + (* OK: SUC i steps taken until first encounter of l + * EL i ms_list = HD ms_list' is among assumptions *) + fs [weak_rel_steps_def] >> + REPEAT STRIP_TAC >| [ + (* HD ms_list' reached in SUC i steps from ms *) + fs [FUNPOW_OPT_LIST_EQ_SOME], + + (* HD ms_list' is either l or in ls *) + IMP_RES_TAC FILTER_MEM >> + QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> (\ms. m.pc ms = l) x`` [`HD ms_list'`] >> + rfs [MEM_HD], + + (* At n' < SUC i steps, we are neither at l nor in ls *) + QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls`` [`n'`] >> + rfs [] >> + ONCE_REWRITE_TAC [EQ_SYM_EQ] >> + `~(\ms. m.pc ms = l) ms'3'` suffices_by ( + fs [] + ) >> + irule FILTER_NOT_MEM >> + Q.EXISTS_TAC `ms_list` >> + Q.EXISTS_TAC `ms_list'` >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + (* OK: ms'3' is in ms_list (since n' < n) but not in ms_list' (since n' < SUC i, so before first encounter) *) + CONJ_TAC >| [ + IMP_RES_TAC FILTER_BEFORE >> + QSPECL_X_ASSUM ``!i'. i' < i ==> ~MEM (EL i' ms_list) ms_list'`` [`PRE n'`] >> + rfs [] >> + `EL (PRE n') ms_list = ms'3'` suffices_by ( + METIS_TAC [] + ) >> + METIS_TAC [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF], + + QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`n'`] >> + rfs [] >> + irule MEM_EL_CONS >> + fs [] + ] + ], - (* OK *) - cheat + (* OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) + irule weak_rel_steps_intermediate_start >> + fs [] >> + Q.EXISTS_TAC `ms` >> + fs [FUNPOW_OPT_LIST_EQ_SOME] ], (* OK: Last element in filtered list can perform weak transition with ending * label set ({l} UNION ls) and reach ms' *) - cheat, + subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( + fs [] + ) >> + subgoal `MEM (EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` >- ( + subgoal `MEM (EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( + fs [listTheory.MEM_EL] >> + Q.EXISTS_TAC `PRE (LENGTH ms_list')` >> + fs [] + ) >> + METIS_TAC [FILTER_MEM] + ) >> + subgoal `?n'''. FUNPOW_OPT m.trs n''' ms = SOME (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) (FILTER (\ms. m.pc ms = l) ms_list)) /\ n''' < n` >- ( + fs [listTheory.MEM_EL] >> + Q.EXISTS_TAC `SUC n'` >> + CONJ_TAC >| [ + fs [FUNPOW_OPT_LIST_EQ_SOME, arithmeticTheory.PRE_SUB1] >> + rw [], + + (* TODO: Last element of ms_list' not being in l contradiction *) + METIS_TAC [weak_rel_steps_FILTER_NOTIN_end] + ] + ) >> + IMP_RES_TAC weak_rel_steps_intermediate_start >> + Q.EXISTS_TAC `n - n'3'` >> + fs [] >> + irule weak_rel_steps_superset_after >> + REPEAT STRIP_TAC >> ( + fs [] + ) >| [ + (* Find appropriate index in ms_list and use it, also lemma that indices after FILTER LAST do + * not have label l *) + Q.EXISTS_TAC `EL (PRE (n'' + n'3')) ms_list` >> + CONJ_TAC >| [ + (* TODO: Lemma for this situation *) + irule FUNPOW_OPT_split3 >> + Q.EXISTS_TAC `n'3'` >> + Q.EXISTS_TAC `ms` >> + fs [] >> + METIS_TAC [FUNPOW_OPT_todoname], + + subgoal `EL (PRE n'3') ms_list = LAST ms_list'` >- ( + cheat + ) >> + IMP_RES_TAC FILTER_AFTER >> + QSPECL_X_ASSUM ``!i'. i' > PRE n'3' ==> ~(\ms. m.pc ms = l) (EL i' ms_list)`` [`(PRE (n'' + n'3'))`] >> + (* TODO: n'' must be proven nonzero from earlier *) + subgoal `n'' > 0` >- ( + cheat + ) >> + `PRE (n'' + n'3') > PRE n'3'` suffices_by ( + fs [] + ) >> + (* Something is still not 100% done here. Think n'3' also has to be proven nonzero *) + Cases_on `n''` >- ( + fs [] + ) >> + Cases_on `n'3'` >- ( + cheat + ) >> + fs [] + ], + + METIS_TAC [], + + METIS_TAC [] + ], (* Inductive case for weak transition with ending label set ({l} UNION ls) - * between elements of the list. Should also be OK *) - cheat + * between elements of the list (where the latter point goes to ms' with ending label set ls). + * Should also be OK *) + subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( + fs [] + ) >> + subgoal `?i'. EL i' ms_list = EL i (FILTER (\ms. m.pc ms = l) ms_list) /\ i' < LENGTH ms_list` >- ( + subgoal `MEM (EL i (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( + fs [rich_listTheory.EL_MEM] + ) >> + fs [listTheory.MEM_FILTER, listTheory.MEM_EL] >> + Q.EXISTS_TAC `n'` >> + rw [] + ) >> + subgoal `?i'. EL i' ms_list = EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list) /\ i' < LENGTH ms_list` >- ( + subgoal `MEM (EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( + fs [rich_listTheory.EL_MEM] + ) >> + fs [listTheory.MEM_FILTER, listTheory.MEM_EL] >> + Q.EXISTS_TAC `n'` >> + rw [] + ) >> + subgoal `i' < i''` >- ( + irule FILTER_ORDER >> + Q.EXISTS_TAC `(\ms. m.pc ms = l)` >> + Q.EXISTS_TAC `i` >> + Q.EXISTS_TAC `ms_list` >> + fs [arithmeticTheory.ADD1] + ) >> + subgoal `n = LENGTH ms_list` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] + ) >> + Q.EXISTS_TAC `SUC i'' - SUC i'` >> + Q.EXISTS_TAC `n - (SUC i'')` >> + fs [] >> + REPEAT STRIP_TAC >| [ + (* Weak transtion to ({l} UNION ls) between element i and element i+1 in ms_list' *) + METIS_TAC [weak_rel_steps_FILTER_inter], + + (* Weak transtion to ls between element i+1 and LAST of ms_list' *) + METIS_TAC [weak_rel_steps_FILTER_end], + + (* Phrased differently: "Why can't a member of ms_list' be the last element in ms_list?" *) + (* TODO: Last element of ms_list' not being in l contradiction *) + cheat + ] ] ); From dc1d13c7b03d5253b8d6c4b68cd200c2025f5604 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 9 May 2022 00:26:25 +0200 Subject: [PATCH 0095/1015] Fixed more cheats in abstract_hoare_logic_partialScript --- .../abstract_hoare_logic_partialScript.sml | 76 +++++++++++++------ 1 file changed, 54 insertions(+), 22 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 2084bcae9..2191396d9 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -1257,7 +1257,7 @@ val weak_rel_steps_superset_after = prove(`` n' < n ==> weak_rel_steps m ms ls ms' n ==> weak_rel_steps m ms'' ls ms' (n - n') ==> - (!n''. n'' < (n-n') ==> (?ms'''. FUNPOW_OPT m.trs n'' ms'' = SOME ms''' /\ m.pc ms''' NOTIN ls')) ==> + (!n''. n'' < (n-n') ==> n'' > 0 ==> (?ms'''. FUNPOW_OPT m.trs n'' ms'' = SOME ms''' /\ m.pc ms''' NOTIN ls')) ==> weak_rel_steps m ms'' (ls' UNION ls) ms' (n - n') ``, @@ -1532,7 +1532,7 @@ subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( *) Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> REPEAT STRIP_TAC >| [ - (* OK: Element in filtered list obeys filter property *) + (* subgoal 1. OK: Element in filtered list obeys filter property *) subgoal `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list))` >- ( (* TODO: Silly, but it works... *) `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list)) /\ MEM (EL i (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` suffices_by ( @@ -1544,7 +1544,7 @@ REPEAT STRIP_TAC >| [ ) >> fs [], - (* OK: If filtered list is empty, l can be inserted in ending label set *) + (* subgoal 2. OK: If filtered list is empty, l can be inserted in ending label set *) fs [weak_rel_steps_def] >> REPEAT STRIP_TAC >> subgoal `?ms''. FUNPOW_OPT m.trs n' ms = SOME ms''` >- ( @@ -1564,7 +1564,7 @@ REPEAT STRIP_TAC >| [ IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> rfs [], - (* OK: First encounter of l is reached when filtered list is non-empty, + (* subgoal 3. OK: First encounter of l is reached when filtered list is non-empty, * also weak transition can proceed from there directly to ending label set *) subgoal `?ms''. ms'' = EL 0 (FILTER (\ms. m.pc ms = l) ms_list)` >- ( METIS_TAC [] @@ -1614,7 +1614,7 @@ REPEAT STRIP_TAC >| [ Q.EXISTS_TAC `SUC i` >> fs [] >> REPEAT STRIP_TAC >| [ - (* OK: SUC i steps taken until first encounter of l + (* subgoal 3a. OK: SUC i steps taken until first encounter of l * EL i ms_list = HD ms_list' is among assumptions *) fs [weak_rel_steps_def] >> REPEAT STRIP_TAC >| [ @@ -1656,14 +1656,14 @@ REPEAT STRIP_TAC >| [ ] ], - (* OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) + (* subgoal 3b. OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) irule weak_rel_steps_intermediate_start >> fs [] >> Q.EXISTS_TAC `ms` >> fs [FUNPOW_OPT_LIST_EQ_SOME] ], - (* OK: Last element in filtered list can perform weak transition with ending + (* subgoal 4. OK: Last element in filtered list can perform weak transition with ending * label set ({l} UNION ls) and reach ms' *) subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( fs [] @@ -1676,15 +1676,18 @@ REPEAT STRIP_TAC >| [ ) >> METIS_TAC [FILTER_MEM] ) >> - subgoal `?n'''. FUNPOW_OPT m.trs n''' ms = SOME (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) (FILTER (\ms. m.pc ms = l) ms_list)) /\ n''' < n` >- ( + (* Note : this introduces n'3', the number of transitions to last encounter of l. *) + subgoal `?n'''. FUNPOW_OPT m.trs n''' ms = SOME (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) (FILTER (\ms. m.pc ms = l) ms_list)) /\ n''' < n /\ n''' > 0` >- ( fs [listTheory.MEM_EL] >> Q.EXISTS_TAC `SUC n'` >> - CONJ_TAC >| [ + REPEAT CONJ_TAC >| [ fs [FUNPOW_OPT_LIST_EQ_SOME, arithmeticTheory.PRE_SUB1] >> rw [], (* TODO: Last element of ms_list' not being in l contradiction *) - METIS_TAC [weak_rel_steps_FILTER_NOTIN_end] + METIS_TAC [weak_rel_steps_FILTER_NOTIN_end], + + fs [] ] ) >> IMP_RES_TAC weak_rel_steps_intermediate_start >> @@ -1705,26 +1708,38 @@ REPEAT STRIP_TAC >| [ fs [] >> METIS_TAC [FUNPOW_OPT_todoname], +(* + subgoal `n'3' < n` >- ( + fs [] + ) >> +*) subgoal `EL (PRE n'3') ms_list = LAST ms_list'` >- ( - cheat + subgoal `FUNPOW_OPT m.trs n'3' ms = SOME (EL (PRE n'3') ms_list)` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`n'3'`] >> + rfs [rich_listTheory.EL_CONS] + ) >> + subgoal `EL (PRE n'3') ms_list = EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) + (FILTER (\ms. m.pc ms = l) ms_list)` >- ( + fs [] + ) >> + fs [] >> + ONCE_REWRITE_TAC [EQ_SYM_EQ] >> + ONCE_REWRITE_TAC [GSYM arithmeticTheory.PRE_SUB1] >> + irule listTheory.LAST_EL >> + fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] ) >> IMP_RES_TAC FILTER_AFTER >> QSPECL_X_ASSUM ``!i'. i' > PRE n'3' ==> ~(\ms. m.pc ms = l) (EL i' ms_list)`` [`(PRE (n'' + n'3'))`] >> - (* TODO: n'' must be proven nonzero from earlier *) - subgoal `n'' > 0` >- ( - cheat - ) >> `PRE (n'' + n'3') > PRE n'3'` suffices_by ( fs [] ) >> - (* Something is still not 100% done here. Think n'3' also has to be proven nonzero *) Cases_on `n''` >- ( fs [] ) >> - Cases_on `n'3'` >- ( - cheat - ) >> - fs [] + Cases_on `n'3'` >> ( + fs [] + ) ], METIS_TAC [], @@ -1732,7 +1747,7 @@ REPEAT STRIP_TAC >| [ METIS_TAC [] ], - (* Inductive case for weak transition with ending label set ({l} UNION ls) + (* subgoal 5. Inductive case for weak transition with ending label set ({l} UNION ls) * between elements of the list (where the latter point goes to ms' with ending label set ls). * Should also be OK *) subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( @@ -1776,7 +1791,24 @@ REPEAT STRIP_TAC >| [ (* Phrased differently: "Why can't a member of ms_list' be the last element in ms_list?" *) (* TODO: Last element of ms_list' not being in l contradiction *) - cheat + Cases_on `SUC i'' = LENGTH ms_list` >- ( + fs [weak_rel_steps_def] >> + subgoal `m.pc (EL i'' ms_list) = l` >- ( + subgoal `MEM (EL i'' ms_list) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( + fs [listTheory.MEM_EL] >> + Q.EXISTS_TAC `i + 1` >> + fs [] + ) >> + fs [listTheory.MEM_FILTER] + ) >> + + subgoal `ms' = EL i'' ms_list` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME, listTheory.LAST_EL] >> + METIS_TAC [listTheory.EL_restricted] + ) >> + METIS_TAC [] + ) >> + fs [] ] ] ); From 6ea09087d397103ba902dac6dbfa28a3c97b17e4 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 10 May 2022 23:58:45 +0200 Subject: [PATCH 0096/1015] Fixes to abstract_hoare_logic_partialScript --- .../abstract_hoare_logic_auxScript.sml | 1207 ++++++++++ .../abstract_hoare_logic_partialScript.sml | 1988 ++++++----------- 2 files changed, 1862 insertions(+), 1333 deletions(-) create mode 100644 src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml new file mode 100644 index 000000000..3c6fb0907 --- /dev/null +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -0,0 +1,1207 @@ +open HolKernel boolLib bossLib BasicProvers dep_rewrite; + +open bir_auxiliaryLib; + +open bir_auxiliaryTheory; + +val _ = new_theory "abstract_hoare_logic_aux"; + +(*******************) +(* Generic lemmata *) +(*******************) + +Theorem EL_LAST_APPEND: + !l x. + EL (LENGTH l) (l ++ [x]) = x +Proof +rpt strip_tac >> +ASSUME_TAC (ISPEC ``l ++ [x]`` rich_listTheory.EL_PRE_LENGTH) >> +fs [GSYM arithmeticTheory.ADD1] +QED + +Theorem LAST_TAKE_EL: + !n l. + n < LENGTH l ==> + EL n l = LAST (TAKE (SUC n) l) +Proof +rpt strip_tac >> +subgoal `(TAKE (SUC n) l) <> []` >- ( + subgoal `LENGTH (TAKE (SUC n) l) = SUC n` >- ( + irule listTheory.LENGTH_TAKE >> + fs [] + ) >> + Cases_on `l` >> ( + fs [] + ) +) >> +IMP_RES_TAC listTheory.LAST_EL >> +fs [] >> +metis_tac [listTheory.EL_TAKE, prim_recTheory.LESS_SUC_REFL] +QED + +Theorem INDEX_FIND_MEM: + !P l x. + P x ==> + MEM x l ==> + ?i x'. INDEX_FIND 0 P l = SOME (i, x') +Proof +Induct_on `l` >> ( + fs [] +) >> +rpt strip_tac >| [ + qexists_tac `0` >> + qexists_tac `h` >> + fs [INDEX_FIND_EQ_SOME_0], + + Cases_on `P h` >| [ + qexists_tac `0` >> + qexists_tac `h` >> + fs [INDEX_FIND_EQ_SOME_0], + + RES_TAC >> + qexists_tac `SUC i` >> + qexists_tac `x'` >> + fs [listTheory.INDEX_FIND_def] >> + REWRITE_TAC [Once listTheory.INDEX_FIND_add] >> + fs [] + ] +] +QED + +Theorem MEM_HD: + !l. + l <> [] ==> + MEM (HD l) l +Proof +Cases_on `l` >> ( + fs [] +) +QED + +Theorem FILTER_MEM: + !P l l' x. + FILTER P l = l' ==> + MEM x l' ==> + P x /\ MEM x l +Proof +rw [] >> +fs [listTheory.MEM_FILTER] +QED + +(* +Theorem MEM_EL_CONS: + !n e l. + n > 0 ==> + n < SUC (LENGTH l) ==> + MEM (EL n (e::l)) l +Proof +rpt strip_tac >> +fs [listTheory.MEM_EL] >> +qexists_tac `PRE n` >> +fs [] >> +irule rich_listTheory.EL_CONS >> +fs [] +QED +*) + +(* +Theorem FILTER_NOT_MEM: +!P l l' x. +FILTER P l = l' ==> +MEM x l ==> +~MEM x l' ==> +~P x +Proof +rpt strip_tac >> +rw [] >> +fs [listTheory.MEM_FILTER] +QED +*) + +(* TODO: Since l can have duplicate elements, we need to make sure + * EL i l is the FIRST encounter of HD l' in l. *) +(* TODO: Might require list nonempty or OLEAST... *) +Theorem FILTER_BEFORE: +(* +!P l l' i. +FILTER P l = l' ==> +EL i l = HD l' ==> +(!i'. i' < i ==> ~P (EL i l) /\ ~MEM (EL i' l) l') +*) + !P l l' i. + FILTER P l = l' ==> + (LEAST i. EL i l = HD l') = i ==> + (!i'. i' < i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') +Proof +cheat +QED + +(* TODO: Since l can have duplicate elements, we need to make sure + * EL i l is the LAST encounter of LAST l' in l. *) +(* TODO: Might require list nonempty or OLEAST... *) +Theorem FILTER_AFTER: + !P l l' i. + FILTER P l = l' ==> + (LEAST i. EL i (REVERSE l) = HD l') = i ==> + (!i'. i' > i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') +Proof +cheat +QED + +(* TODO: This is just plain wrong... *) +Theorem FILTER_ORDER: + !P l i i' i''. + EL i' l = EL i (FILTER P l) ==> + EL i'' l = EL (SUC i) (FILTER P l) ==> + i' < i'' +Proof +cheat +QED + +Theorem INDEX_FIND_SUFFIX: +!P n i x_list x. +i < n ==> +INDEX_FIND 0 P x_list = SOME (PRE n, x) ==> +INDEX_FIND 0 P (DROP i x_list) = SOME (PRE (n - i), x) +Proof +cheat +QED + +Theorem EL_PRE_CONS_EQ: +!i x x_list x_list'. + EL (SUC i) (x::x_list) = EL (SUC i) (x::x_list') ==> + EL i x_list = EL i x_list' +Proof +fs [] +QED + + +(*******************) +(* FUNPOW_OPT *) +(*******************) + +(* +val FUNPOW_ASSOC = prove(`` +!f m n x. +FUNPOW f m (FUNPOW f n x) = FUNPOW f n (FUNPOW f m x)``, + +fs [GSYM arithmeticTheory.FUNPOW_ADD] +); +*) + +Theorem FUNPOW_OPT_step: + !f n x x' x''. + FUNPOW_OPT f (SUC n) x = SOME x'' ==> + f x = SOME x' ==> + FUNPOW_OPT f n x' = SOME x'' +Proof +rpt strip_tac >> +fs [FUNPOW_OPT_REWRS] +QED + +Theorem FUNPOW_OPT_INTER: + !f n n' ms ms' ms''. + (FUNPOW_OPT f n ms = SOME ms') ==> + (FUNPOW_OPT f (n'+n) ms = SOME ms'') ==> + (FUNPOW_OPT f n' ms' = SOME ms'') +Proof +metis_tac [FUNPOW_OPT_def, + arithmeticTheory.FUNPOW_ADD] +QED + +(* TODO: Use FUNPOW_OPT_next_n_NONE instead of this *) +Theorem FUNPOW_OPT_ADD_NONE: + !f n n' ms ms'. + (FUNPOW_OPT f n ms = SOME ms') ==> + (FUNPOW_OPT f n' ms' = NONE) ==> + (FUNPOW_OPT f (n'+n) ms = NONE) +Proof +metis_tac [FUNPOW_OPT_def, + arithmeticTheory.FUNPOW_ADD] +QED + +Theorem FUNPOW_OPT_PRE: + !f n x x' x''. + n > 0 ==> + FUNPOW_OPT f n x = SOME x' ==> + f x = SOME x'' ==> + FUNPOW_OPT f (PRE n) x'' = SOME x' +Proof +rpt strip_tac >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_REWRS] +) +QED + +Theorem FUNPOW_SUB: + !f m n x. + m > n ==> + FUNPOW f (m - n) (FUNPOW f n x) = FUNPOW f m x +Proof +fs [GSYM arithmeticTheory.FUNPOW_ADD] +QED + +(* +(* TODO: Same as FUNPOW_OPT_INTER with commutativity of addition *) +val FUNPOW_OPT_split = prove(`` +!f n n' s s' s''. +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f (n + n') s = SOME s'' ==> +FUNPOW_OPT f n' s' = SOME s''``, + +metis_tac [FUNPOW_ASSOC, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +); +*) + +Theorem FUNPOW_OPT_split2: +!f n' n s s'' s'. +n > n' ==> +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f n' s = SOME s'' ==> +FUNPOW_OPT f (n - n') s'' = SOME s' +Proof +rpt strip_tac >> +metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +QED + + +(*******************) +(* FUNPOW_OPT_LIST *) +(*******************) + +(* Head-recursive version (nicer for most proofs) *) +Definition FUNPOW_OPT_LIST_def: + (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ + (FUNPOW_OPT_LIST f (SUC n) s = + case FUNPOW_OPT_LIST f n s of + | SOME res_prefix => + (case f (LAST res_prefix) of + | SOME res_last => SOME (SNOC res_last res_prefix) + | NONE => NONE) + | NONE => NONE) +End + +Theorem FUNPOW_OPT_LIST_SUC_NONE: + !f n s l. + FUNPOW_OPT_LIST f n s = SOME l ==> + f (LAST l) = NONE ==> + FUNPOW_OPT f (SUC n) s = NONE +Proof +cheat +QED + +Theorem FUNPOW_OPT_LIST_SUC_SOME: + !f n s l x. + FUNPOW_OPT_LIST f n s = SOME l ==> + f (LAST l) = SOME x ==> + FUNPOW_OPT f (SUC n) s = SOME x +Proof +cheat +QED + +Theorem FUNPOW_OPT_LIST_NEQ_NONE_PREV: + !f n s l. + FUNPOW_OPT_LIST f n s = SOME l ==> + !n'. n' <= n ==> FUNPOW_OPT f n' s <> NONE +Proof +cheat +QED + +(* TODO: Split up in two theorems, one specific for FUNPOW_OPT equivalence? *) +Theorem FUNPOW_OPT_LIST_EQ_SOME: + !f n s l. + FUNPOW_OPT_LIST f n s = SOME l <=> + LENGTH l = (SUC n) /\ + FUNPOW_OPT f n s = SOME (LAST l) /\ + (!n'. n' <= n ==> FUNPOW_OPT f n' s = SOME (EL n' l)) /\ + !i. (SUC i) < LENGTH l ==> + f (EL i l) = SOME (EL (SUC i) l) +Proof +cheat +(* TODO: Use FUNPOW_OPT_LIST_NEQ_NONE_PREV *) +QED + +Theorem FUNPOW_OPT_LIST_EQ_NONE: + !f n s. + FUNPOW_OPT_LIST f n s = NONE <=> + ?n'. n' <= n /\ FUNPOW_OPT f n' s = NONE /\ + (* TODO: Overkill? What is needed on LHS? *) + (!n''. n'' < n' ==> (FUNPOW_OPT f n'' s <> NONE)) +Proof +rpt strip_tac >> +EQ_TAC >| [ + rpt strip_tac >> + Induct_on `n` >- ( + rpt strip_tac >> + qexists_tac `0` >> + fs [FUNPOW_OPT_LIST_def] + ) >> + rpt strip_tac >> + fs [FUNPOW_OPT_LIST_def] >> + Cases_on `FUNPOW_OPT_LIST f n s` >> ( + fs [] + ) >| [ + qexists_tac `n'` >> + fs [], + + Cases_on `f (LAST x)` >> ( + fs [] + ) >> + qexists_tac `SUC n` >> + fs [] >> + CONJ_TAC >| [ + (* Looks OK, might be a lemma *) + metis_tac [FUNPOW_OPT_LIST_SUC_NONE], + + (* Should follow from FUNPOW_OPT_LIST_EQ_SOME - break out to separate lemma? *) + rpt strip_tac >> + IMP_RES_TAC FUNPOW_OPT_LIST_NEQ_NONE_PREV >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT f n' s <> NONE`` [`n''`] >> + rfs [] + ] + ], + + rpt strip_tac >> + fs [FUNPOW_OPT_LIST_def] >> + Induct_on `n` >| [ + rpt strip_tac >> + fs [FUNPOW_OPT_def], + + rpt strip_tac >> + fs [FUNPOW_OPT_LIST_def] >> + Cases_on `n' = SUC n` >- ( + fs [] >> + Cases_on `FUNPOW_OPT_LIST f n s` >> ( + fs [] + ) >> + Cases_on `f (LAST x)` >> ( + fs [] + ) >> + fs [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_SUC_SOME >> + fs [] + ) >> + fs [] + ] +] +QED + +(* Tail-recursive evaluation of FUNPOW_OPT_LIST *) +Theorem FUNPOW_OPT_LIST_tail: + !f n s l. + (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ + (FUNPOW_OPT_LIST f (SUC n) s = + case f s of + | SOME res_head => + (case FUNPOW_OPT_LIST f n res_head of + | SOME res_tail => SOME (s::res_tail) + | NONE => NONE) + | NONE => NONE) +Proof +rpt strip_tac >| [ + fs [FUNPOW_OPT_LIST_def], + + Cases_on `f s` >| [ + fs [FUNPOW_OPT_LIST_EQ_NONE] >> + qexists_tac `1` >> + fs [FUNPOW_OPT_compute] >> + rpt strip_tac >> + Cases_on `n''` >> ( + fs [FUNPOW_OPT_compute] + ), + + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + Induct_on `n` >> ( + fs [FUNPOW_OPT_LIST_def] + ) >> + Cases_on `FUNPOW_OPT_LIST f n x` >- ( + fs [FUNPOW_OPT_LIST_def] + ) >> + Cases_on `x'` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] + ) >> + Cases_on `f (LAST (h::t))` >> ( + fs [] + ) >> + fs [listTheory.LAST_compute] + ] +] +QED + +Theorem FUNPOW_OPT_LIST_NONEMPTY: + !f n x l. + FUNPOW_OPT_LIST f n x = SOME l ==> + l <> [] +Proof +rpt strip_tac >> +rw [] >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_LIST_def] +) >> +Cases_on `FUNPOW_OPT_LIST f n' x` >> ( + fs [] +) >> +Cases_on `f (LAST x')` >> ( + fs [] +) +QED + +Theorem FUNPOW_OPT_LIST_LAST: + !f n x l_opt. + FUNPOW_OPT_LIST f n x = l_opt ==> + (case l_opt of + | SOME l => + FUNPOW_OPT f n x = SOME (LAST l) + | NONE => FUNPOW_OPT f n x = NONE) +Proof +rpt strip_tac >> +Cases_on `l_opt` >| [ + fs [FUNPOW_OPT_LIST_EQ_NONE] >> + subgoal `?n''. n = n' + n''` >- ( + qexists_tac `n - n'` >> + fs [] + ) >> + metis_tac [FUNPOW_OPT_next_n_NONE], + + fs [FUNPOW_OPT_LIST_EQ_SOME] +] +QED + +Theorem FUNPOW_OPT_LIST_NONE: + !f n x. + FUNPOW_OPT_LIST f n x = NONE ==> + FUNPOW_OPT_LIST f (SUC n) x = NONE +Proof +fs [FUNPOW_OPT_LIST_def] +QED + +(* +Theorem FUNPOW_OPT_LIST_CONS: + !f x n t. + FUNPOW_OPT_LIST f n x = SOME t ==> + ((?h. f (LAST t) = SOME h /\ + FUNPOW_OPT_LIST f (SUC n) x = SOME (SNOC h t)) \/ FUNPOW_OPT_LIST f (SUC n) x = NONE) +Proof +rpt strip_tac >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_LIST_def] +) >| [ + rw [] >> + Cases_on `f x` >> ( + fs [] + ), + + Cases_on `FUNPOW_OPT_LIST f n' x` >> ( + fs [] + ) >> + Cases_on `f (LAST x')` >> ( + fs [] + ) >> + Cases_on `f (LAST t)` >> ( + fs [] + ) +] +QED +*) + +Theorem FUNPOW_OPT_LIST_FRONT_PRE: + !f x n t. + FUNPOW_OPT_LIST f (SUC n) x = SOME t ==> + FUNPOW_OPT_LIST f n x = SOME (FRONT t) +Proof +rpt strip_tac >> +fs [FUNPOW_OPT_LIST_def] >> +Cases_on `FUNPOW_OPT_LIST f n x` >> ( + fs [] +) >> +Cases_on `f (LAST x')` >> ( + fs [] +) >> +rw [listTheory.FRONT_DEF] >> +fs [rich_listTheory.FRONT_APPEND] +QED + +Theorem FUNPOW_OPT_LIST_BACK_PRE: + !f x x' n l. + FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> + f x = SOME x' ==> + FUNPOW_OPT_LIST f n x' = SOME (TL l) +Proof +rpt strip_tac >> +fs [FUNPOW_OPT_LIST_tail] >> +Cases_on `FUNPOW_OPT_LIST f n x'` >> ( + fs [] +) >> +rw [] +QED + +Theorem FUNPOW_OPT_LIST_BACK_INCR: + !f x x' n t. + FUNPOW_OPT_LIST f n x' = SOME t ==> + f x = SOME x' ==> + FUNPOW_OPT_LIST f (SUC n) x = SOME (x::t) +Proof +rpt strip_tac >> +fs [FUNPOW_OPT_LIST_tail] +QED + +Theorem FUNPOW_OPT_LIST_LENGTH: + !n l f x. + FUNPOW_OPT_LIST f n x = SOME l ==> + LENGTH l = (SUC n) +Proof +Induct_on `n` >- ( + fs [FUNPOW_OPT_LIST_def] +) >> +rpt strip_tac >> +subgoal `FUNPOW_OPT_LIST f n x = SOME (FRONT l)` >- ( + metis_tac [FUNPOW_OPT_LIST_FRONT_PRE] +) >> +RES_TAC >> +IMP_RES_TAC FUNPOW_OPT_LIST_NONEMPTY >> +IMP_RES_TAC rich_listTheory.LENGTH_FRONT >> +fs [] +QED + +Theorem FUNPOW_OPT_SUBLIST: + !f n n' x l. + n' <= n ==> + FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> + FUNPOW_OPT_LIST f (SUC n − n') (LAST (TAKE (SUC n') l)) = SOME (DROP n' l) ==> + FUNPOW_OPT_LIST f (n − n') (LAST (TAKE (SUC (SUC n')) l)) = SOME (DROP (SUC n') l) +Proof +rpt strip_tac >> +fs [FUNPOW_OPT_LIST_EQ_SOME] >> +rpt strip_tac >| [ + (* OK: starting one step later but taking one step less leads to same end result *) + irule FUNPOW_OPT_step >> + qexists_tac `LAST (TAKE (SUC n') l)` >> + fs [] >> + strip_tac >| [ + QSPECL_X_ASSUM ``!i. SUC i < LENGTH l ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> + rfs [] >> + `EL n' l = LAST (TAKE (SUC n') l) /\ EL (SUC n') l = LAST (TAKE (SUC (SUC n')) l)` suffices_by ( + rpt strip_tac >> + fs [] >> + rw [] + ) >> + strip_tac >> ( + irule LAST_TAKE_EL >> + fs [] + ), + + subgoal `EL (SUC n - n') (DROP n' l) = EL (SUC (n - n')) (DROP n' l)` >- ( + fs [arithmeticTheory.SUB_LEFT_SUC] >> + Cases_on `n = n'` >> ( + fs [] + ) + ) >> + fs [listTheory.last_drop] + ], + + (* OK: starting one step later, and then taking steps that won't let you reach the end of l + * makes you reach the associated index of l *) + irule FUNPOW_OPT_INTER >> + qexists_tac `x` >> + qexists_tac `SUC n'` >> + rfs [] >> + strip_tac >| [ + irule LAST_TAKE_EL >> + fs [], + + ONCE_REWRITE_TAC [EQ_SYM_EQ] >> + irule listTheory.EL_DROP >> + fs [] + ], + + (* OK: Property should hold for element i of sublist starting from element SUC n' *) + QSPECL_X_ASSUM ``!i. SUC i < LENGTH l - n' ==> + f (EL i (DROP n' l)) = SOME (EL (SUC i) (DROP n' l))`` [`SUC i`] >> + rfs [] >> + subgoal `EL (SUC i) (DROP n' l) = EL i (DROP (SUC n') l)` >- ( + fs [rich_listTheory.DROP_CONS_EL] + ) >> + subgoal `EL (SUC (SUC i)) (DROP n' l) = EL (SUC i) (DROP (SUC n') l)` >- ( + fs [rich_listTheory.DROP_CONS_EL] + ) >> + fs [] +] +QED + +Theorem FUNPOW_OPT_LIST_APPEND: + !f n n' x l. + n' <= n ==> + FUNPOW_OPT_LIST f n x = SOME l ==> + ?l' l''. + FUNPOW_OPT_LIST f n' x = SOME l' /\ + FUNPOW_OPT_LIST f (n - n') (LAST l') = SOME l'' /\ + l' ++ (DROP 1 l'') = l +Proof +rpt strip_tac >> +qexists_tac `TAKE (SUC n') l` >> +qexists_tac `DROP n' l` >> +rpt strip_tac >| [ + Induct_on `n'` >- ( + strip_tac >> + Cases_on `n` >- ( + fs [FUNPOW_OPT_LIST_def] >> + rw [] + ) >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + Cases_on `l` >> ( + fs [] + ) + ) >> + rpt strip_tac >> + Q.SUBGOAL_THEN `n' ≤ n` (fn thm => fs [thm]) >- ( + fs [] + ) >> + fs [FUNPOW_OPT_LIST_def] >> + Cases_on `f (LAST (TAKE (SUC n') l))` >- ( + fs [] >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n'. + n' <= n ==> + FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> + rfs [] >> + QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> + rfs [] >> + Q.SUBGOAL_THEN `LAST (TAKE (SUC n') l) = EL n' l` (fn thm => fs [thm]) >- ( + fs [] + ) + ) >> + fs [] >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + subgoal `x' = EL (SUC n') l` >- ( + QSPECL_X_ASSUM ``!n'. + n' <= n ==> + FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> + rfs [] >> + QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> + rfs [] >> + `LAST (TAKE (SUC n') l) = EL n' l` suffices_by ( + rpt strip_tac >> + fs [] + ) >> + ONCE_REWRITE_TAC [EQ_SYM_EQ] >> + irule LAST_TAKE_EL >> + fs [] + ) >> + rw [] >> + Q.SUBGOAL_THEN `TAKE (SUC (SUC n')) l = TAKE (SUC n') l ++ TAKE 1 (DROP (SUC n') l)` (fn thm => fs [thm]) >- ( + Q.SUBGOAL_THEN `(SUC (SUC n')) = (SUC n') + 1` (fn thm => fs [thm]) >- ( + fs [arithmeticTheory.ADD1] + ) >> + fs [listTheory.TAKE_SUM] + ) >> + fs [listTheory.TAKE1_DROP], + + (* Start off after n' steps, take n - n' steps *) + Induct_on `n'` >- ( + strip_tac >> + fs [] >> + Q.SUBGOAL_THEN `TAKE 1 l = [x]` (fn thm => fs [thm]) >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + Cases_on `n` >- ( + fs [FUNPOW_OPT_def] >> + subgoal `l <> []` >- ( + Cases_on `l` >> ( + fs [] + ) + ) >> + fs [listTheory.TAKE1] + ) >> + QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT f n'' x = SOME (EL n'' l)`` [`0`] >> + fs [FUNPOW_OPT_def] >> + subgoal `l <> []` >- ( + Cases_on `l` >> ( + fs [] + ) + ) >> + fs [listTheory.TAKE1] + ) + ) >> + Cases_on `n` >- ( + fs [] + ) >> + rpt strip_tac >> + Q.SUBGOAL_THEN `n' ≤ SUC n''` (fn thm => fs [thm]) >- ( + fs [] + ) >> + (* If you take one more step, if you start one step earlier, then the result is the same as before + * with one less step dropped (from head) *) + irule FUNPOW_OPT_SUBLIST >> + fs [] >> + qexists_tac `x` >> + fs [], + + fs [rich_listTheory.DROP_DROP_T, arithmeticTheory.ADD1] +] +QED + +Theorem FUNPOW_OPT_LIST_EL_SOME: + !f n n' x l. + FUNPOW_OPT_LIST f n x = SOME l ==> + n' <= n ==> + ?x'. FUNPOW_OPT f n' x = SOME x' +Proof +rpt strip_tac >> +IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> +qexists_tac `LAST l'` >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] +QED + +Theorem FUNPOW_OPT_LIST_EL_NONE: + !f n n' x. + FUNPOW_OPT_LIST f n x = NONE ==> + (n' >= n) ==> + FUNPOW_OPT f n' x = NONE +Proof +rpt strip_tac >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] >> +subgoal `?n''. n' = n + n''` >- ( + fs [arithmeticTheory.LESS_EQUAL_ADD] +) >> +metis_tac [FUNPOW_OPT_next_n_NONE] +QED + +Theorem FUNPOW_OPT_LIST_EL_NEXT: + !f n x x'. + FUNPOW_OPT_LIST f n x = SOME x' ==> + FUNPOW_OPT f (SUC n) x = f (LAST x') +Proof +rpt strip_tac >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] >> +Cases_on `f (LAST x')` >| [ + fs [arithmeticTheory.ADD1] >> + ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> + irule FUNPOW_OPT_ADD_NONE >> + qexists_tac `LAST x'` >> + fs [FUNPOW_OPT_compute], + + fs [arithmeticTheory.ADD1] >> + ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> + irule FUNPOW_OPT_ADD_thm >> + qexists_tac `LAST x'` >> + fs [FUNPOW_OPT_compute] +] +QED + +Theorem FUNPOW_OPT_LIST_EXISTS: + !f n n' x x'. + FUNPOW_OPT f n x = SOME x' ==> + n' <= n ==> + ?l. FUNPOW_OPT_LIST f n' x = SOME l +Proof +Induct_on `n` >- ( + rpt strip_tac >> + qexists_tac `[x']` >> + fs [] >> + rw [] >> + fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] +) >> +rpt strip_tac >> +Cases_on `n' = SUC n` >- ( + fs [FUNPOW_OPT_LIST_def] >> + Cases_on `FUNPOW_OPT_LIST f n x` >- ( + fs [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_NONE >> + subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( + irule FUNPOW_OPT_prev_EXISTS >> + qexists_tac `SUC n` >> + qexists_tac `x'` >> + fs [] + ) >> + IMP_RES_TAC (Q.SPECL [`f`, `n`, `SUC n`, `x`] FUNPOW_OPT_LIST_EL_NONE) >> + fs [] + ) >> + Cases_on `f (LAST x'')` >- ( + fs [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_EL_NEXT >> + fs [] + ) >> + fs [] +) >> +subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( + irule FUNPOW_OPT_prev_EXISTS >> + qexists_tac `SUC n` >> + qexists_tac `x'` >> + fs [] +) >> +QSPECL_X_ASSUM ``!f n' x x'. _`` [`f`, `n'`, `x`, `x''`] >> +fs [] +QED + +Theorem FUNPOW_OPT_LIST_EXISTS_nicer: + !f n n' x x'. + FUNPOW_OPT f n x = SOME x' ==> + n' <= n ==> + ?l. FUNPOW_OPT_LIST f n' x = SOME (x::(SNOC x' l)) +Proof +cheat +QED + +Theorem FUNPOW_OPT_LIST_EL: + !f n n' x x' l. + FUNPOW_OPT_LIST f n x = SOME l ==> + n' <= n ==> + FUNPOW_OPT f n' x = SOME x' ==> + (EL n' l) = x' +Proof +rpt strip_tac >> +IMP_RES_TAC (Q.SPECL [`f`, `n`, `n'`, `x`, `l`] FUNPOW_OPT_LIST_APPEND) >> +subgoal `EL n' l = LAST l'` >- ( + rw [] >> + IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> + Q.SUBGOAL_THEN `n' = PRE (LENGTH l')` (fn thm => REWRITE_TAC [thm]) >- ( + fs [] + ) >> + Q.SUBGOAL_THEN `EL (PRE (LENGTH l')) (l' ++ DROP 1 l'') = EL (PRE (LENGTH l')) l'` (fn thm => REWRITE_TAC [thm]) >- ( + irule rich_listTheory.EL_APPEND1 >> + fs [] + ) >> + irule rich_listTheory.EL_PRE_LENGTH >> + Cases_on `l'` >> ( + fs [] + ) +) >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [] +QED + +(* +Theorem FUNPOW_OPT_LIST_INDEX_FIND: + !f P n x l i x'. + FUNPOW_OPT_LIST f n x = SOME l ==> + INDEX_FIND 0 P l = SOME (i, x') ==> + FUNPOW_OPT f i x = SOME x' +Proof +rpt strip_tac >> +fs [INDEX_FIND_EQ_SOME_0] >> +IMP_RES_TAC (Q.SPECL [`f`, `n`, `i`, `x`, `l`] FUNPOW_OPT_LIST_EL_SOME) >> +QSPECL_X_ASSUM ``!i. _`` [`i`] >> +IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> +rfs [] >> +fs [] >> +rfs [] >> +IMP_RES_TAC (Q.SPECL [`f`, `n`, `x`, `l`] FUNPOW_OPT_LIST_EQ_SOME) >> +QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT f n' x = SOME (EL n' l)`` [`i`] >> +rfs [] +QED +*) + +Theorem FUNPOW_OPT_LIST_FIRST: + !f n x x' x_list. + n > 0 ==> + FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> + f x = SOME x' ==> + FUNPOW_OPT_LIST f (PRE n) x' = SOME x_list +Proof +rpt strip_tac >> +Cases_on `n` >- ( + fs [] +) >> +fs [FUNPOW_OPT_LIST_EQ_SOME, FUNPOW_OPT_REWRS] >> +rpt CONJ_TAC >| [ + QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT f n'' x = SOME (EL n'' (x::x_list))`` [`SUC n'`] >> + Cases_on `x_list` >- ( + fs [] + ) >> + fs [listTheory.LAST_CONS], + + rpt strip_tac >> + QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT f n'' x = SOME (EL n'' (x::x_list))`` [`SUC n''`] >> + rfs [FUNPOW_OPT_REWRS], + + rpt strip_tac >> + QSPECL_X_ASSUM ``!i. i < LENGTH x_list ==> f (EL i (x::x_list)) = SOME (EL i x_list)`` [`SUC i`] >> + fs [] +] +QED + +Theorem FUNPOW_OPT_LIST_PRE: + !f n x x' x_list. + n > 0 ==> + FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> + f x = SOME x' ==> + FUNPOW_OPT_LIST f (PRE n) x' = SOME x_list +Proof +rpt strip_tac >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_LIST_tail] +) >> +Cases_on `FUNPOW_OPT_LIST f n' x'` >> ( + fs [] +) +QED + +Theorem FUNPOW_OPT_LIST_SUFFIX: +!f n i x x_list. +FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> +FUNPOW_OPT_LIST f (n - SUC i) (EL i x_list) = SOME (EL i x_list::DROP (SUC i) x_list) +Proof +cheat +QED + +(* +val FUNPOW_OPT_todoname = prove(`` +!f n n' n'' P ms ms_list. +FUNPOW_OPT_LIST f n ms = SOME (ms::ms_list) ==> +FUNPOW_OPT f n'' ms = + SOME + (EL (LENGTH (FILTER P ms_list) - 1) + (FILTER P ms_list)) ==> +n' < n - n'' ==> +FUNPOW_OPT f (n' + n'') ms = SOME (EL (PRE (n' + n'')) ms_list)``, + +rpt strip_tac >> +fs [FUNPOW_OPT_LIST_EQ_SOME] >> +irule rich_listTheory.EL_CONS >> +(* TODO: Likely not provable... *) +cheat +); +*) + +(* For weak_rel_steps_list_states_subgoal_2_lemma *) +Theorem FUNPOW_OPT_LIST_FILTER_NULL: +!f n x x' x_list P P'. + n > 0 ==> + FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> + INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> + FILTER P' x_list = [] ==> + INDEX_FIND 0 (\x. P x \/ P' x) x_list = SOME (PRE n,x') +Proof +rpt strip_tac >> +subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( + irule FUNPOW_OPT_LIST_EL_SOME >> + qexists_tac `x::x_list` >> + qexists_tac `n` >> + fs [] +) >> +fs [listTheory.FILTER_EQ_NIL] >> +subgoal `EL (PRE n) x_list = x''` >- ( + subgoal `(EL n (x::x_list)) = x''` >- ( + irule FUNPOW_OPT_LIST_EL >> + qexists_tac `f` >> + qexists_tac `n` >> + qexists_tac `x` >> + fs [] + ) >> + metis_tac [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] +) >> +fs [INDEX_FIND_EQ_SOME_0, listTheory.EVERY_EL] +QED + +Theorem FUNPOW_OPT_LIST_PREFIX: +!f n n' i x x_list x_list'. + FUNPOW_OPT_LIST f n x = SOME x_list ==> + FUNPOW_OPT_LIST f n' x = SOME x_list' ==> + n' <= n ==> + x_list' <<= x_list +Proof +rpt strip_tac >> +fs [rich_listTheory.IS_PREFIX_APPEND] >> +IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> +qexists_tac `DROP 1 l''` >> +rw [] >> +fs [] +QED + +Theorem FUNPOW_OPT_LIST_EL_EQ: +!f n n' i x x_list x_list'. + FUNPOW_OPT_LIST f n x = SOME x_list ==> + FUNPOW_OPT_LIST f n' x = SOME x_list' ==> + n' < n ==> + i <= n' ==> + EL i x_list' = EL i x_list +Proof +rpt strip_tac >> +irule rich_listTheory.is_prefix_el >> +rpt strip_tac >| [ + fs [FUNPOW_OPT_LIST_EQ_SOME], + + fs [FUNPOW_OPT_LIST_EQ_SOME], + + irule FUNPOW_OPT_LIST_PREFIX >> + qexists_tac `f` >> + qexists_tac `n` >> + qexists_tac `n'` >> + qexists_tac `x` >> + fs [] +] +QED + +Theorem FUNPOW_OPT_LIST_FILTER_FIRST: +!f n x x' x_list P P'. + FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> + INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> + LENGTH (FILTER P' x_list) > 0 ==> + ~P' (LAST x_list) ==> + ?n'. + (n' > 0 /\ + ?x_list'. + FUNPOW_OPT_LIST f n' x = SOME (x::x_list') /\ + INDEX_FIND 0 (\x''. P' x'' \/ P x'') x_list' = SOME (PRE n', HD (FILTER P' x_list))) /\ + (n > n' /\ + ?x_list'. + FUNPOW_OPT_LIST f (n - n') + (HD (FILTER P' x_list)) = + SOME (HD (FILTER P' x_list)::x_list') /\ + INDEX_FIND 0 P x_list' = SOME (PRE (n - n'), x')) /\ n' < n /\ n' > 0 +Proof +rpt strip_tac >> +subgoal `?x''. x'' = EL 0 (FILTER P' x_list)` >- ( + metis_tac [] +) >> +subgoal `?x_list'. FILTER P' x_list = x_list'` >- ( + fs [] +) >> +subgoal `LENGTH x_list > 0` >- ( + cheat +) >> +subgoal `?i. x'' = EL i x_list /\ i < (PRE n)` >- ( + subgoal `?i. SOME x'' = oEL i x_list` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + IMP_RES_TAC FILTER_MEM >> + QSPECL_X_ASSUM ``!x. MEM x x_list' ==> MEM x ms_list`` [`x''`] >> + Q.SUBGOAL_THEN `MEM (HD x_list') x_list'` (fn thm => rfs [thm]) >- ( + rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) >> + fs [listTheory.MEM_EL] >> + qexists_tac `n'` >> + fs [listTheory.oEL_THM] + ) >> + qexists_tac `i` >> + fs [listTheory.oEL_EQ_EL, FUNPOW_OPT_LIST_EQ_SOME] >> + (* Left to prove: Why can't x'' be the last element in x_list? *) + Cases_on `i = PRE n` >- ( + subgoal `P' x''` >- ( + IMP_RES_TAC FILTER_MEM >> + QSPECL_X_ASSUM ``!x. MEM x x_list' ==> P' x`` [`x''`] >> + Q.SUBGOAL_THEN `MEM (HD x_list') x_list'` (fn thm => rfs [thm]) >- ( + rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) + ) >> + subgoal `LAST x_list = x'` >- ( + cheat + ) >> + subgoal `x'' = x'` >- ( + fs [INDEX_FIND_EQ_SOME_0] + ) >> + rw [] >> + fs [] + ) >> + fs [] +) >> +qexists_tac `SUC i` >> +fs [] >> +rpt strip_tac >| [ + (* subgoal 3a. OK: SUC i steps taken until first encounter of l + * EL i ms_list = HD ms_list' is among assumptions *) + subgoal `?x_list''. FUNPOW_OPT_LIST f (SUC i) x = SOME (x::x_list'')` >- ( + cheat + ) >> + qexists_tac `x_list''` >> + fs [] >> + REWRITE_TAC [INDEX_FIND_EQ_SOME_0] >> + rpt strip_tac >| [ + fs [FUNPOW_OPT_LIST_EQ_SOME], + + subgoal `EL i x_list'' = EL i x_list` >- ( + cheat + ) >> + fs [], + + subgoal `MEM (HD x_list') (FILTER P' x_list')` >- ( + cheat + ) >> + fs [listTheory.MEM_FILTER], + + (* Before first element in filter list, neither P' nor P holds *) + (* P': by FILTER_BEFORE *) + (* P: by INDEX_FIND 0 P x_list = SOME (PRE n,x') *) + fs [] >| [ + subgoal `(LEAST i. EL i x_list = HD x_list') = i` >- ( + cheat + ) >> + IMP_RES_TAC FILTER_BEFORE >> + `EL j' x_list'' = EL j' x_list` suffices_by ( + metis_tac [] + ) >> + irule EL_PRE_CONS_EQ >> + qexists_tac `x` >> + irule FUNPOW_OPT_LIST_EL_EQ >> + qexists_tac `f` >> + qexists_tac `n` >> + qexists_tac `SUC i` >> + qexists_tac `x` >> + fs [], + + fs [INDEX_FIND_EQ_SOME_0] >> + QSPECL_X_ASSUM ``!j'. j' < PRE n ==> ~P (EL j' x_list)`` [`j'`] >> + rfs [] >> + `EL j' x_list'' = EL j' x_list` suffices_by ( + metis_tac [] + ) >> + irule EL_PRE_CONS_EQ >> + qexists_tac `x` >> + irule FUNPOW_OPT_LIST_EL_EQ >> + qexists_tac `f` >> + qexists_tac `n` >> + qexists_tac `SUC i` >> + qexists_tac `x` >> + fs [] + ] + ], + + (* subgoal 3b. OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) + qexists_tac `DROP (SUC i) x_list` >> + rpt strip_tac >| [ + metis_tac [FUNPOW_OPT_LIST_SUFFIX], + + irule INDEX_FIND_SUFFIX >> + fs [] + ] +] +QED + +Theorem FUNPOW_OPT_LIST_FILTER_LAST: +!f n x x' x_list x_list' P P'. + FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> + INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> + FILTER P' x_list = x_list' ==> + LENGTH x_list' > 0 ==> + ?n'. (?x_list''. + FUNPOW_OPT_LIST f n' (LAST x_list') = + SOME (LAST x_list'::x_list'') /\ + INDEX_FIND 0 (\x''. P' x'' \/ P x'') x_list'' = + SOME (PRE n', x')) /\ n' > 0 +Proof +cheat +QED + +Theorem FUNPOW_OPT_LIST_FILTER_BETWEEN: +!f n x x' x_list x_list' P P' i. + FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> + INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> + FILTER P' x_list = x_list' ==> + i < (LENGTH x_list') - 1 ==> + ?n' n''. + (?x_list''. + FUNPOW_OPT_LIST f n' (EL i x_list') = + SOME (EL i x_list'::x_list'') /\ + INDEX_FIND 0 (\x''. P' x'' \/ P x'') x_list'' = + SOME (PRE n', EL (i + 1) x_list')) /\ + (?x_list''. + FUNPOW_OPT_LIST f n'' (EL (i + 1) x_list') = + SOME (EL (i + 1) x_list'::x_list'') /\ + INDEX_FIND 0 P x_list'' = SOME (PRE n'', x')) /\ + n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0 +Proof +cheat +QED + +val _ = export_theory(); diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 2191396d9..1d0d2dc6b 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -1,929 +1,139 @@ -open HolKernel Parse boolLib bossLib; +open HolKernel boolLib bossLib BasicProvers dep_rewrite; open bir_auxiliaryLib; open bir_auxiliaryTheory; -open abstract_hoare_logicTheory; +open abstract_hoare_logic_auxTheory abstract_hoare_logicTheory; val _ = new_theory "abstract_hoare_logic_partial"; -val weak_rel_steps_def = Define ` - weak_rel_steps m ms ls ms' n = - ((n > 0 /\ - FUNPOW_OPT m.trs n ms = SOME ms' /\ - m.pc ms' IN ls) /\ - !n'. - (n' < n /\ n' > 0 ==> - ?ms''. - FUNPOW_OPT m.trs n' ms = SOME ms'' /\ - ~(m.pc ms'' IN ls) - ))`; - -val weak_rel_steps_equiv = prove(`` - !m ms ls ms'. - weak_model m ==> - (m.weak ms ls ms' <=> - ?n. weak_rel_steps m ms ls ms' n) - ``, +Definition weak_rel_steps_def: + weak_rel_steps m ms ls ms' n = + ((n > 0 /\ + FUNPOW_OPT m.trs n ms = SOME ms' /\ + m.pc ms' IN ls) /\ + !n'. + (n' < n /\ n' > 0 ==> + ?ms''. + FUNPOW_OPT m.trs n' ms = SOME ms'' /\ + ~(m.pc ms'' IN ls) + )) +End + +Theorem weak_rel_steps_imp: + !m ms ls ms' n. + weak_model m ==> + (weak_rel_steps m ms ls ms' n ==> + m.weak ms ls ms') +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +qexists_tac `n` >> +fs [weak_rel_steps_def] +QED -REPEAT STRIP_TAC >> +Theorem weak_rel_steps_equiv: + !m ms ls ms'. + weak_model m ==> + (m.weak ms ls ms' <=> + ?n. weak_rel_steps m ms ls ms' n) +Proof +rpt strip_tac >> EQ_TAC >> ( - STRIP_TAC + strip_tac ) >| [ PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - Q.EXISTS_TAC `n` >> + qexists_tac `n` >> fs [weak_rel_steps_def], - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - fs [weak_rel_steps_def] >> - Q.EXISTS_TAC `n` >> - REPEAT STRIP_TAC >> ( - fs [] - ) + metis_tac [weak_rel_steps_imp] ] -); - -val weak_rel_steps_imp = prove(`` - !m ms ls ms' n. - weak_model m ==> - (weak_rel_steps m ms ls ms' n ==> - m.weak ms ls ms') - ``, - -REPEAT STRIP_TAC >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -Q.EXISTS_TAC `n` >> -fs [weak_rel_steps_def] -); - -val weak_rel_steps_label = prove(`` - !m ms ls ms' n. - weak_model m ==> - weak_rel_steps m ms ls ms' n ==> - m.pc ms' IN ls - ``, +QED +Theorem weak_rel_steps_label: + !m ms ls ms' n. + weak_model m ==> + weak_rel_steps m ms ls ms' n ==> + m.pc ms' IN ls +Proof fs [weak_rel_steps_def] -); - -(* Returns a list of n successive applications of f on s *) -(* Hard for proofs? -val FUNPOW_OPT_LIST_def = Define ` - (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ - (FUNPOW_OPT_LIST f (SUC n) s = - case f s of - | SOME res_hd => - (case FUNPOW_OPT_LIST f n res_hd of - | SOME res_tl => SOME (res_hd::res_tl) - | NONE => NONE) - | NONE => NONE)`; -*) - -(* Head-recursive version (nicer for most proofs) *) -val FUNPOW_OPT_LIST_def = Define ` - (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ - (FUNPOW_OPT_LIST f (SUC n) s = - case FUNPOW_OPT_LIST f n s of - | SOME res_prefix => - (case f (LAST res_prefix) of - | SOME res_last => SOME (SNOC res_last res_prefix) - | NONE => NONE) - | NONE => NONE)`; - -(* TODO: Split up in two theorems, one specific for FUNPOW_OPT equivalence? *) -val FUNPOW_OPT_LIST_EQ_SOME = prove(`` -!f n s l. -FUNPOW_OPT_LIST f n s = SOME l <=> -LENGTH l = (SUC n) /\ -FUNPOW_OPT f n s = SOME (LAST l) /\ -(!n'. n' <= n ==> FUNPOW_OPT f n' s = SOME (EL n' l)) /\ -!i. (SUC i) < LENGTH l ==> -f (EL i l) = SOME (EL (SUC i) l) -``, - -cheat -); - -val FUNPOW_OPT_LIST_EQ_NONE = prove(`` -!f n s. -FUNPOW_OPT_LIST f n s = NONE <=> -?n'. n' <= n /\ FUNPOW_OPT f n' s = NONE /\ -(* TODO: Overkill? *) -(!n''. n'' < n' ==> (FUNPOW_OPT f n'' s <> NONE)) -``, - -REPEAT STRIP_TAC >> -EQ_TAC >| [ - REPEAT STRIP_TAC >> - (* Looks OK *) - cheat, - - REPEAT STRIP_TAC >> - (* Looks OK *) - cheat -] -); - -(* -(* Tail-recursive version (useful for a few proofs) *) -val FUNPOW_OPT_LIST_tailrec_def = Define ` - (FUNPOW_OPT_LIST_tailrec f 0 s = SOME [s]) /\ - (FUNPOW_OPT_LIST_tailrec f (SUC n) s = - case f s of - | SOME res_hd => - (case FUNPOW_OPT_LIST_tailrec f n res_hd of - | SOME res_tl => SOME (res_hd::res_tl) - | NONE => NONE) - | NONE => NONE)`; - -val FUNPOW_OPT_LIST_tailrec_EQ_SOME = prove(`` -!f n s l. -FUNPOW_OPT_LIST_tailrec f n s = SOME l <=> -LENGTH l = (SUC n) /\ -FUNPOW_OPT f n s = SOME (LAST l) /\ -(!n'. n' <= n ==> FUNPOW_OPT f n' s = SOME (EL n' l)) /\ -!i. (SUC i) < LENGTH l ==> -f (EL i l) = SOME (EL (SUC i) l) -``, - -cheat -); - -val FUNPOW_OPT_LIST_tailreq_equiv = prove(`` -!f n s. -FUNPOW_OPT_LIST f n s = FUNPOW_OPT_LIST_tailrec f n s -``, - -(* TODO: Break up into lemmata... *) -cheat - -(* -Induct_on `n` >- ( - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LIST_tailrec_def] -) >> -fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LIST_tailrec_def] >> -REPEAT STRIP_TAC >> -Cases_on `FUNPOW_OPT_LIST_tailrec f n s` >| [ - (* Case: result became NONE somewhere before last step *) - cheat, - - (* Case: result is still SOME right before last step *) - IMP_RES_TAC FUNPOW_OPT_LIST_tailrec_SOME >> - fs [] >> - (* f s could not have been NONE, since FUNPOW_OPT_LIST_tailrec f n s is SOME*) - subgoal `?x. f s = SOME x` >- ( - cheat - ) >> - fs [] >> -) >> -Cases_on `FUNPOW_OPT_LIST_tailrec f n s` >> ( - fs [] -) >> -Cases_on `f s` >> ( - fs [] -) >> - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LIST_tailrec_def] -) >> -cheat -*) -); -*) - -(* -val FUNPOW_OPT_LISTS_def = Define ` - (FUNPOW_OPT_LISTS f [] s = SOME [s]) /\ - (FUNPOW_OPT_LISTS f (h::t) s = - case FUNPOW_OPT_LISTS f t s of - | SOME res_tl => - (case f (LAST res_tl) of - | SOME res_hd => SOME (res_hd::res_tl) - | NONE => NONE) - | NONE => NONE)`; -*) - -val FUNPOW_OPT_LIST_0 = prove(`` -!f x. -FUNPOW_OPT_LIST f 0 x = SOME [x] -``, - -REPEAT STRIP_TAC >> -fs [FUNPOW_OPT_LIST_def] -); - -val FUNPOW_OPT_LIST_NONEMPTY = prove(`` -!f n x l. -FUNPOW_OPT_LIST f n x = SOME l ==> -l <> [] -``, - -REPEAT STRIP_TAC >> -rw [] >> -Cases_on `n` >> ( - fs [FUNPOW_OPT_LIST_def] -) >> -Cases_on `FUNPOW_OPT_LIST f n' x` >> ( - fs [] -) >> -Cases_on `f (LAST x')` >> ( - fs [] -) -); - -val FUNPOW_OPT_LIST_LAST = prove(`` -!f n x l_opt. -FUNPOW_OPT_LIST f n x = l_opt ==> -(case l_opt of - | SOME l => - FUNPOW_OPT f n x = SOME (LAST l) - | NONE => FUNPOW_OPT f n x = NONE) -``, - -REPEAT STRIP_TAC >> -Cases_on `l_opt` >| [ - (* TODO: Prove EQ_NONE theorem? *) - fs [FUNPOW_OPT_LIST_EQ_NONE] >> - subgoal `?n''. n = n' + n''` >- ( - Q.EXISTS_TAC `n - n'` >> - fs [] - ) >> - METIS_TAC [FUNPOW_OPT_next_n_NONE], - - (* Using EQ_SOME: *) - fs [FUNPOW_OPT_LIST_EQ_SOME] -(* OLD: - Cases_on `n` >- ( - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] >> - rw [] - ) >> - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] >> - Cases_on `FUNPOW_OPT_LIST f n' x` >> ( - fs [] - ) >> - Cases_on `f (LAST x'')` >> ( - fs [] - ) >> - fs [arithmeticTheory.FUNPOW] >> - (* TODO: Tail-recursive vs. head-recursive definitions *) - cheat -*) -] -); - -val FUNPOW_OPT_LIST_CONS = prove(`` -!f x n t. -FUNPOW_OPT_LIST f n x = SOME t ==> -((?h. f (LAST t) = SOME h /\ - FUNPOW_OPT_LIST f (SUC n) x = SOME (SNOC h t)) \/ FUNPOW_OPT_LIST f (SUC n) x = NONE) -``, - -REPEAT STRIP_TAC >> -Cases_on `n` >> ( - fs [FUNPOW_OPT_LIST_def] -) >| [ - rw [] >> - Cases_on `f x` >> ( - fs [] - ), +QED - Cases_on `FUNPOW_OPT_LIST f n' x` >> ( - fs [] - ) >> - Cases_on `f (LAST x')` >> ( - fs [] - ) >> - Cases_on `f (LAST t)` >> ( - fs [] - ) -] -); - -val FUNPOW_OPT_LIST_FRONT_PRE = prove(`` -!f x n t. -FUNPOW_OPT_LIST f (SUC n) x = SOME t ==> -FUNPOW_OPT_LIST f n x = SOME (FRONT t) -``, - -REPEAT STRIP_TAC >> -fs [FUNPOW_OPT_LIST_def] >> -Cases_on `FUNPOW_OPT_LIST f n x` >> ( - fs [] -) >> -Cases_on `f (LAST x')` >> ( - fs [] -) >> -rw [listTheory.FRONT_DEF] >> -fs [rich_listTheory.FRONT_APPEND] -); - -val FUNPOW_OPT_LIST_BACK_PRE = prove(`` -!f x x' n l. -FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> -f x = SOME x' ==> -FUNPOW_OPT_LIST f n x' = SOME (TL l) -``, - -cheat -); - -val FUNPOW_OPT_LIST_BACK_INCR = prove(`` -!f x x' n t. -FUNPOW_OPT_LIST f n x' = SOME t ==> -f x = SOME x' ==> -FUNPOW_OPT_LIST f (SUC n) x = SOME (x::t) -``, - -cheat -); - -val FUNPOW_OPT_LIST_INCR2 = prove(`` -!f x n h t. -FUNPOW_OPT_LIST f n x = SOME t ==> -LENGTH t = (SUC n) ==> -f (LAST t) = SOME h ==> -FUNPOW_OPT_LIST f (SUC n) x = SOME (SNOC h t) /\ LENGTH (SNOC h t) = (SUC (SUC n)) -``, - -REPEAT STRIP_TAC >> -fs [FUNPOW_OPT_LIST_def] -); - -(* -val FUNPOW_OPT_LISTS_LENGTH = prove(`` -!l' l f x. -FUNPOW_OPT_LISTS f l' x = SOME l ==> -LENGTH l = (SUC (LENGTH l')) -``, - -cheat -); - -val FUNPOW_OPT_LISTS_EQUIV = prove(`` -!l' l f x. -FUNPOW_OPT_LISTS f l' x = SOME l <=> -FUNPOW_OPT_LIST f (LENGTH l') x = SOME l -``, - -REPEAT STRIP_TAC >> +Theorem weak_rel_steps_to_FUNPOW_OPT_LIST: + !m ms ls ms' n. + weak_model m ==> + (weak_rel_steps m ms ls ms' n <=> + n > 0 /\ + ?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) /\ + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n, ms')) +Proof +rpt strip_tac >> EQ_TAC >> ( - REPEAT STRIP_TAC -) >> -Induct_on `l` >> Induct_on `l'` >> - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_LISTS_def] >> - - Cases_on `FUNPOW_OPT_LISTS f l' x` >> ( - fs [] - ) >> - Cases_on `FUNPOW_OPT_LIST f (LENGTH l') x` >> ( - fs [] - ) >> - Cases_on `f (LAST x')` >> ( - fs [] - ) >> - - Cases_on `f (LAST x'')` >> ( - fs [] - ) >> -); -*) - -val FUNPOW_OPT_LIST_LENGTH = prove(`` -!n l f x. -FUNPOW_OPT_LIST f n x = SOME l ==> -LENGTH l = (SUC n) -``, - -Induct_on `n` >- ( - fs [FUNPOW_OPT_LIST_def] -) >> -REPEAT STRIP_TAC >> -subgoal `FUNPOW_OPT_LIST f n x = SOME (FRONT l)` >- ( - METIS_TAC [FUNPOW_OPT_LIST_FRONT_PRE] -) >> -RES_TAC >> -IMP_RES_TAC FUNPOW_OPT_LIST_NONEMPTY >> -IMP_RES_TAC rich_listTheory.LENGTH_FRONT >> -fs [] - -(* Using FUNPOW_OPT_LISTS: -REPEAT STRIP_TAC >> -subgoal `?l'. n = LENGTH l'` >- ( - Q.EXISTS_TAC `REPLICATE n a` >> - fs [rich_listTheory.LENGTH_REPLICATE] -) >> -fs [GSYM FUNPOW_OPT_LISTS_EQUIV] >> -METIS_TAC [FUNPOW_OPT_LISTS_LENGTH] -*) -); - -val FUNPOW_OPT_step = prove(`` -!f n x x' x''. -FUNPOW_OPT f (SUC n) x = SOME x'' ==> -f x = SOME x' ==> -FUNPOW_OPT f n x' = SOME x'' -``, - -REPEAT STRIP_TAC >> -fs [FUNPOW_OPT_REWRS] -); - -val FUNPOW_OPT_INTER = store_thm ("FUNPOW_OPT_INTER", - ``!f n n' ms ms' ms''. - (FUNPOW_OPT f n ms = SOME ms') ==> - (FUNPOW_OPT f (n'+n) ms = SOME ms'') ==> - (FUNPOW_OPT f n' ms' = SOME ms'') - ``, - -METIS_TAC [FUNPOW_OPT_def, - arithmeticTheory.FUNPOW_ADD] -); - -val FUNPOW_OPT_SUBLIST = prove(`` -!f n n' x l. -n' <= n ==> -FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> -FUNPOW_OPT_LIST f (SUC n − n') (LAST (TAKE (SUC n') l)) = SOME (DROP n' l) ==> -FUNPOW_OPT_LIST f (n − n') (LAST (TAKE (SUC (SUC n')) l)) = SOME (DROP (SUC n') l) -``, + rpt strip_tac +) >| [ + fs [weak_rel_steps_def], -REPEAT STRIP_TAC >> -fs [FUNPOW_OPT_LIST_EQ_SOME] >> -REPEAT STRIP_TAC >| [ - (* OK: starting one step later but taking one step less leads to same end result *) - irule FUNPOW_OPT_step >> - Q.EXISTS_TAC `LAST (TAKE (SUC n') l)` >> + fs [weak_rel_steps_def] >> + IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS_nicer >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST m.trs n' ms = SOME (ms::SNOC ms' l)`` [`n`] >> fs [] >> - STRIP_TAC >| [ - QSPECL_X_ASSUM ``!i. SUC i < LENGTH l ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> - rfs [] >> - (* OK modulo basic list operations *) - cheat, - - subgoal `EL (SUC n - n') (DROP n' l) = EL (SUC (n - n')) (DROP n' l)` >- ( - fs [arithmeticTheory.SUB_LEFT_SUC] >> - Cases_on `n = n'` >> ( - fs [] - ) - ) >> - fs [listTheory.last_drop] - ], + fs [INDEX_FIND_EQ_SOME_0, FUNPOW_OPT_LIST_EQ_SOME] >> + rpt strip_tac >| [ + rw [] >> + fs [EL_LAST_APPEND], - (* OK: starting one step later, and then taking steps that won't let you reach the end of l - * makes you reach the associated index of l *) - irule FUNPOW_OPT_INTER >> - Q.EXISTS_TAC `x` >> - Q.EXISTS_TAC `n'` >> - rfs [] >> - STRIP_TAC >| [ - (* OK modulo basic list operations *) - cheat, - - (* OK modulo basic list operations *) - cheat + QSPECL_X_ASSUM ``!n'. n' < n /\ n' > 0 ==> m.pc (EL n' (ms::SNOC ms' l)) NOTIN ls`` [`SUC j'`] >> + gs [listTheory.SNOC_APPEND] ], - (* OK: Property should hold for element i of sublist starting from element SUC n' *) - QSPECL_X_ASSUM ``!i. SUC i < LENGTH l - n' ==> - f (EL i (DROP n' l)) = SOME (EL (SUC i) (DROP n' l))`` [`SUC i`] >> - rfs [] >> - subgoal `EL (SUC i) (DROP n' l) = EL i (DROP (SUC n') l)` >- ( - (* OK modulo basic list operations *) - cheat - ) >> - subgoal `EL (SUC (SUC i)) (DROP n' l) = EL (SUC i) (DROP (SUC n') l)` >- ( - (* OK modulo basic list operations *) - cheat - ) >> - fs [] -] -); - -val FUNPOW_OPT_LIST_APPEND = prove(`` -!f n n' x l. -n' <= n ==> -FUNPOW_OPT_LIST f n x = SOME l ==> -?l' l''. -FUNPOW_OPT_LIST f n' x = SOME l' /\ -FUNPOW_OPT_LIST f (n - n') (LAST l') = SOME l'' /\ -l' ++ (DROP 1 l'') = l -``, - -REPEAT STRIP_TAC >> -Q.EXISTS_TAC `TAKE (SUC n') l` >> -Q.EXISTS_TAC `DROP n' l` >> -REPEAT STRIP_TAC >| [ - Induct_on `n'` >- ( - STRIP_TAC >> - Cases_on `n` >- ( - fs [FUNPOW_OPT_LIST_def] >> - rw [] + fs [FUNPOW_OPT_LIST_EQ_SOME, INDEX_FIND_EQ_SOME_0, weak_rel_steps_def] >> + rpt strip_tac >| [ + fs [listTheory.LAST_DEF] >> + subgoal `ms_list <> []` >- ( + Cases_on `ms_list` >> ( + fs [] + ) ) >> -(* OLD: - (* TODO: tail-recursive vs. head-recursive definitions *) - cheat -*) - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - (* OK modulo basic list operations *) - cheat - ) >> - REPEAT STRIP_TAC >> - Q.SUBGOAL_THEN `n' ≤ n` (fn thm => fs [thm]) >- ( - fs [] - ) >> - fs [FUNPOW_OPT_LIST_def] >> - Cases_on `f (LAST (TAKE (SUC n') l))` >- ( - fs [] >> -(* OLD: - (* Cannot have been NONE, since result is SOME for greater number of steps *) - cheat -*) - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n'. - n' <= n ==> - FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> - rfs [] >> - QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> - rfs [] >> - Q.SUBGOAL_THEN `LAST (TAKE (SUC n') l) = EL n' l` (fn thm => fs [thm]) >- ( - fs [] - ) - ) >> - fs [] >> -(* OLD: - (* Requires to prove that x' is the result of transition n' + 1 *) - cheat -*) - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - subgoal `x' = EL (SUC n') l` >- ( - QSPECL_X_ASSUM ``!n'. - n' <= n ==> - FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> - rfs [] >> - QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> - rfs [] >> - (* OK modulo basic list operations *) - cheat - ) >> - (* OK modulo basic list operations *) - cheat, - - (* Start off after n' steps, take n - n' steps *) - Induct_on `n'` >- ( - STRIP_TAC >> - fs [] >> - Q.SUBGOAL_THEN `TAKE 1 l = [x]` (fn thm => fs [thm]) >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - Cases_on `n` >- ( - fs [FUNPOW_OPT_def] >> - (* OK modulo basic list operations *) - cheat - ) >> - QSPECL_X_ASSUM ``!n''. _`` [`0`] >> - fs [FUNPOW_OPT_def] >> - (* OK modulo basic list operations *) - cheat -(* OLD: - (* TODO: tail-recursive vs. head-recursive definitions *) - cheat -*) - ) - ) >> - Cases_on `n` >- ( - fs [] - ) >> - REPEAT STRIP_TAC >> - Q.SUBGOAL_THEN `n' ≤ SUC n''` (fn thm => fs [thm]) >- ( - fs [] - ) >> - (* If you take one more step, if you start one step earlier, then the result is the same as before - * with one less step dropped (from head) *) - irule FUNPOW_OPT_SUBLIST >> - fs [] >> - Q.EXISTS_TAC `x` >> - fs [], + rw [] >> + metis_tac [listTheory.LAST_EL], - fs [rich_listTheory.DROP_DROP_T, arithmeticTheory.ADD1] -] -); - -val FUNPOW_OPT_LIST_EL_SOME = prove(`` -!f n n' x l. -FUNPOW_OPT_LIST f n x = SOME l ==> -n' <= n ==> -?x'. FUNPOW_OPT f n' x = SOME x' -``, - -REPEAT STRIP_TAC >> -IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> -Q.EXISTS_TAC `LAST l'` >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] -); - -val FUNPOW_OPT_LIST_EL_NONE = prove(`` -!f n n' x. -FUNPOW_OPT_LIST f n x = NONE ==> -(n' >= n) ==> -FUNPOW_OPT f n' x = NONE -``, - -REPEAT STRIP_TAC >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] >> -subgoal `?n''. n' = n + n''` >- ( - fs [arithmeticTheory.LESS_EQUAL_ADD] -) >> -METIS_TAC [FUNPOW_OPT_next_n_NONE] -); - -(* TODO: Use FUNPOW_OPT_next_n_NONE instead of this *) -val FUNPOW_OPT_ADD_NONE = store_thm ("FUNPOW_OPT_ADD_NONE", - ``!f n n' ms ms'. - (FUNPOW_OPT f n ms = SOME ms') ==> - (FUNPOW_OPT f n' ms' = NONE) ==> - (FUNPOW_OPT f (n'+n) ms = NONE)``, - -METIS_TAC [FUNPOW_OPT_def, - arithmeticTheory.FUNPOW_ADD] -); - -val FUNPOW_OPT_LIST_EL_NEXT = prove(`` -!f n x x'. -FUNPOW_OPT_LIST f n x = SOME x' ==> -FUNPOW_OPT f (SUC n) x = f (LAST x') -``, - -REPEAT STRIP_TAC >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] >> -Cases_on `f (LAST x')` >| [ - fs [arithmeticTheory.ADD1] >> - ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> - irule FUNPOW_OPT_ADD_NONE >> - Q.EXISTS_TAC `LAST x'` >> - fs [FUNPOW_OPT_compute], - - fs [arithmeticTheory.ADD1] >> - ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> - irule FUNPOW_OPT_ADD_thm >> - Q.EXISTS_TAC `LAST x'` >> - fs [FUNPOW_OPT_compute] -] -(* OLD: -(* TODO: tail vs. head FUNPOW_OPT *) -cheat -*) -); - -val FUNPOW_OPT_LIST_NONE = prove(`` -!f n x. -FUNPOW_OPT_LIST f n x = NONE ==> -FUNPOW_OPT_LIST f (SUC n) x = NONE -``, - -fs [FUNPOW_OPT_LIST_def] -); - -val FUNPOW_OPT_LIST_EXISTS = prove(`` -!f n n' x x'. -FUNPOW_OPT f n x = SOME x' ==> -n' <= n ==> -?l. FUNPOW_OPT_LIST f n' x = SOME l -``, - -Induct_on `n` >- ( - REPEAT STRIP_TAC >> - Q.EXISTS_TAC `[x']` >> - fs [] >> - rw [] >> - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] -) >> -REPEAT STRIP_TAC >> -Cases_on `n' = SUC n` >- ( - fs [FUNPOW_OPT_LIST_def] >> - Cases_on `FUNPOW_OPT_LIST f n x` >- ( - fs [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_NONE >> - subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( - irule FUNPOW_OPT_prev_EXISTS >> - Q.EXISTS_TAC `SUC n` >> - Q.EXISTS_TAC `x'` >> + QSPECL_X_ASSUM ``!j'. j' < PRE n ==> m.pc (EL j' ms_list) NOTIN ls`` [`PRE n'`] >> + gs [] >> + `EL n' (ms::ms_list) = EL (PRE n') ms_list` suffices_by ( + strip_tac >> fs [] ) >> - IMP_RES_TAC (Q.SPECL [`f`, `n`, `SUC n`, `x`] FUNPOW_OPT_LIST_EL_NONE) >> - fs [] - ) >> - Cases_on `f (LAST x'')` >- ( - fs [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_EL_NEXT >> - fs [] - ) >> - fs [] -) >> -subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( - irule FUNPOW_OPT_prev_EXISTS >> - Q.EXISTS_TAC `SUC n` >> - Q.EXISTS_TAC `x'` >> - fs [] -) >> -QSPECL_X_ASSUM ``!f n' x x'. _`` [`f`, `n'`, `x`, `x''`] >> -fs [] -); - -val FUNPOW_OPT_LIST_EL = prove(`` -!f n n' x x' l. -FUNPOW_OPT_LIST f n x = SOME l ==> -n' <= n ==> -FUNPOW_OPT f n' x = SOME x' ==> -(EL n' l) = x' -``, - -REPEAT STRIP_TAC >> -IMP_RES_TAC (Q.SPECL [`f`, `n`, `n'`, `x`, `l`] FUNPOW_OPT_LIST_APPEND) >> -subgoal `EL n' l = LAST l'` >- ( - rw [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - Q.SUBGOAL_THEN `n' = PRE (LENGTH l')` (fn thm => REWRITE_TAC [thm]) >- ( - fs [] - ) >> - Q.SUBGOAL_THEN `EL (PRE (LENGTH l')) (l' ++ DROP 1 l'') = EL (PRE (LENGTH l')) l'` (fn thm => REWRITE_TAC [thm]) >- ( - irule rich_listTheory.EL_APPEND1 >> - fs [] - ) >> - irule rich_listTheory.EL_PRE_LENGTH >> - Cases_on `l'` >> ( - fs [] - ) -) >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] -); - -val FUNPOW_OPT_LIST_INDEX_FIND = prove(`` -!f P n x l i x'. -FUNPOW_OPT_LIST f n x = SOME l ==> -INDEX_FIND 0 P l = SOME (i, x') ==> -FUNPOW_OPT f i x = SOME x' -``, - -REPEAT STRIP_TAC >> -fs [INDEX_FIND_EQ_SOME_0] >> -IMP_RES_TAC (Q.SPECL [`f`, `n`, `i`, `x`, `l`] FUNPOW_OPT_LIST_EL_SOME) >> -QSPECL_X_ASSUM ``!i. _`` [`i`] >> -IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> -rfs [] >> -fs [] >> -rfs [] >> -IMP_RES_TAC (Q.SPECL [`f`, `n`, `x`, `l`] FUNPOW_OPT_LIST_EQ_SOME) >> -QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT f n' x = SOME (EL n' l)`` [`i`] >> -rfs [] -); - -val INDEX_FIND_MEM = prove(`` -!P l x. -P x ==> -MEM x l ==> -?i x'. INDEX_FIND 0 P l = SOME (i, x') -``, - -Induct_on `l` >> ( - fs [] -) >> -REPEAT STRIP_TAC >| [ - Q.EXISTS_TAC `0` >> - Q.EXISTS_TAC `h` >> - fs [INDEX_FIND_EQ_SOME_0], - - Cases_on `P h` >| [ - Q.EXISTS_TAC `0` >> - Q.EXISTS_TAC `h` >> - fs [INDEX_FIND_EQ_SOME_0], - - RES_TAC >> - Q.EXISTS_TAC `SUC i` >> - Q.EXISTS_TAC `x'` >> - fs [listTheory.INDEX_FIND_def] >> - REWRITE_TAC [Once listTheory.INDEX_FIND_add] >> + irule rich_listTheory.EL_CONS >> fs [] ] ] -); - -val MEM_HD = prove(`` -!l. -MEM (HD l) l -``, - -cheat -); - -val FILTER_MEM = prove(`` -!P l l' x. -FILTER P l = l' ==> -MEM x l' ==> -P x /\ MEM x l -``, - -rw [] >> -fs [listTheory.MEM_FILTER] -); - -(* -val FILTER_LAST = prove(`` -!P l l' x. -LENGTH (FILTER P l) > 0 ==> -?i. EL (PRE (LENGTH (FILTER P l))) (FILTER P l) = EL i l -``, - -cheat -); -*) - -val MEM_EL_CONS = prove(`` -!n e l. -n > 0 ==> -n < SUC (LENGTH l) ==> -MEM (EL n (e::l)) l -``, - -cheat -); - -val FILTER_NOT_MEM = prove(`` -!P l l' x. -FILTER P l = l' ==> -MEM x l ==> -~MEM x l' ==> -~P x -``, - -cheat -); - -val FILTER_BEFORE = prove(`` -!P l l' i. -FILTER P l = l' ==> -EL i l = HD l' ==> -(!i'. i' < i ==> ~P (EL i l) /\ ~MEM (EL i' l) l') -``, - -cheat -); +QED -val FILTER_AFTER = prove(`` -!P l l' i. -FILTER P l = l' ==> -EL i l = LAST l' ==> -(!i'. i' > i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') -``, - -cheat -); - -val FILTER_ORDER = prove(`` -!P l i i' i''. -EL i' l = EL i (FILTER P l) ==> -EL i'' l = EL (SUC i) (FILTER P l) ==> -i' < i'' -``, - -cheat -); - -val FUNPOW_OPT_LIST_FIRST = prove(`` -!f n x x' x_list. -n > 0 ==> -FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> -f x = SOME x' ==> -FUNPOW_OPT_LIST f (PRE n) x' = SOME x_list -``, - -cheat -); (* If ms and ms' are not related by weak transition to ls for n transitions, * but if taking n transitions from ms takes you to ms' with a label in ls, * then there has to exist an ms'' and a *smallest* n' such that the label of * ms'' is in ls. *) -val weak_rel_steps_smallest_exists = prove(`` - !m. - weak_model m ==> - !ms ls ms' n. - ~(weak_rel_steps m ms ls ms' n) ==> - n > 0 ==> - FUNPOW_OPT m.trs n ms = SOME ms' ==> - m.pc ms' IN ls ==> - ?n' ms''. - n' < n /\ n' > 0 /\ - FUNPOW_OPT m.trs n' ms = SOME ms'' /\ - m.pc ms'' IN ls /\ - (!n''. - (n'' < n' /\ n'' > 0 ==> - ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ - ~(m.pc ms''' IN ls))) - ``, - -REPEAT STRIP_TAC >> +(* TODO: Lemmatize further *) +Theorem weak_rel_steps_smallest_exists: + !m. + weak_model m ==> + !ms ls ms' n. + ~(weak_rel_steps m ms ls ms' n) ==> + n > 0 ==> + FUNPOW_OPT m.trs n ms = SOME ms' ==> + m.pc ms' IN ls ==> + ?n' ms''. + n' < n /\ n' > 0 /\ + FUNPOW_OPT m.trs n' ms = SOME ms'' /\ + m.pc ms'' IN ls /\ + (!n''. + (n'' < n' /\ n'' > 0 ==> + ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ + ~(m.pc ms''' IN ls))) +Proof +rpt strip_tac >> fs [weak_rel_steps_def] >> subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> @@ -932,64 +142,64 @@ subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( Cases_on `n` >- ( fs [FUNPOW_OPT_LIST_def] ) >> - (* TODO: Should be OK... *) - cheat -(* OLD - irule FUNPOW_OPT_LIST_EXISTS >> - Q.EXISTS_TAC `n` >> - fs [] -*) + qexists_tac `DROP 1 l` >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n'. n' <= SUC n'' ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' l)`` [`0`] >> + fs [FUNPOW_OPT_def] >> + Cases_on `l` >> ( + fs [] + ) ) >> subgoal `?i ms''. INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( (* OK: There is at least ms', possibly some earlier encounter of ls *) irule INDEX_FIND_MEM >> - Q.EXISTS_TAC `ms'` >> + qexists_tac `ms'` >> fs [listTheory.MEM_EL] >> - Q.EXISTS_TAC `PRE n` >> (* Note: Indexing change *) + qexists_tac `PRE n` >> CONJ_TAC >| [ IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - fs [] >> - (* OK modulo some arithmetic *) - cheat, + fs [], REWRITE_TAC [Once EQ_SYM_EQ] >> irule FUNPOW_OPT_LIST_EL >> fs [] >> subgoal `?ms''. m.trs ms = SOME ms''` >- ( - (* TODO: Should be OK... *) - cheat + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`1`] >> + fs [FUNPOW_OPT_def] ) >> - Q.EXISTS_TAC `m.trs` >> - Q.EXISTS_TAC `PRE n` >> - Q.EXISTS_TAC `ms''` >> + qexists_tac `m.trs` >> + qexists_tac `PRE n` >> + qexists_tac `ms''` >> fs [] >> CONJ_TAC >| [ - cheat, + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + metis_tac [FUNPOW_OPT_PRE], - METIS_TAC [FUNPOW_OPT_LIST_FIRST] + metis_tac [FUNPOW_OPT_LIST_FIRST] ] ] ) >> -Q.EXISTS_TAC `SUC i` >> -Q.EXISTS_TAC `ms''` >> +qexists_tac `SUC i` >> +qexists_tac `ms''` >> fs [] >> subgoal `?ms'''. FUNPOW_OPT m.trs n' ms = SOME ms'''` >- ( - METIS_TAC [FUNPOW_OPT_prev_EXISTS] + metis_tac [FUNPOW_OPT_prev_EXISTS] ) >> -REPEAT STRIP_TAC >| [ +rpt strip_tac >| [ (* i < n since i must be at least n', since INDEX_FIND at least must have found ms''', * if not any earlier encounter *) fs [INDEX_FIND_EQ_SOME_0] >> Cases_on `n' < (SUC i)` >| [ (* Contradiction: ms''' occurs earlier than the first encounter of ls found by INDEX_FIND *) - subgoal `m.pc (EL (PRE n') ms_list) NOTIN ls` >- ( (* Note: Indexing change *) + subgoal `m.pc (EL (PRE n') ms_list) NOTIN ls` >- ( fs [] ) >> - subgoal `(EL (PRE n') ms_list) = ms'''` >- ( (* Note: Indexing change *) + subgoal `(EL (PRE n') ms_list) = ms'''` >- ( subgoal `(EL n' (ms::ms_list)) = ms'''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + metis_tac [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] ) >> - METIS_TAC [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] + metis_tac [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] ) >> fs [], @@ -1006,36 +216,45 @@ REPEAT STRIP_TAC >| [ fs [] ) >> subgoal `?ms''''. FUNPOW_OPT m.trs n'' ms = SOME ms''''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL_SOME, arithmeticTheory.LESS_IMP_LESS_OR_EQ] + metis_tac [FUNPOW_OPT_LIST_EL_SOME, arithmeticTheory.LESS_IMP_LESS_OR_EQ] ) >> subgoal `(EL (PRE n'') ms_list) = ms''''` >- ( irule FUNPOW_OPT_LIST_EL >> subgoal `?ms'''''. m.trs ms = SOME ms'''''` >- ( - (* TODO: Should be OK... *) - cheat + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`1`] >> + fs [FUNPOW_OPT_def] ) >> - Q.EXISTS_TAC `m.trs` >> - Q.EXISTS_TAC `PRE n` >> - Q.EXISTS_TAC `ms'''''` >> + qexists_tac `m.trs` >> + qexists_tac `PRE n` >> + qexists_tac `ms'''''` >> fs [] >> - (* TODO: Should be OK... *) - cheat + rpt CONJ_TAC >| [ + irule arithmeticTheory.PRE_LESS_EQ >> + fs [], + + metis_tac [FUNPOW_OPT_PRE], + + subgoal `n > 0` >- ( + fs [] + ) >> + metis_tac [FUNPOW_OPT_LIST_PRE] + ] ) >> fs [INDEX_FIND_EQ_SOME_0] >> rw [] ] -); +QED -val weak_rel_steps_intermediate_labels = prove(`` +Theorem weak_rel_steps_intermediate_labels: !m. weak_model m ==> !ms ls1 ls2 ms' n. weak_rel_steps m ms ls1 ms' n ==> ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> ?ms'' n'. weak_rel_steps m ms ls2 ms'' n' /\ n' < n - ``, - -REPEAT STRIP_TAC >> +Proof +rpt strip_tac >> fs [weak_rel_steps_def] >> rfs [] >> subgoal `?n' ms''. @@ -1048,181 +267,71 @@ subgoal `?n' ms''. ~(m.pc ms''' IN (ls1 UNION ls2))))` >- ( irule weak_rel_steps_smallest_exists >> fs [weak_rel_steps_def] >> - Q.EXISTS_TAC `n'` >> - REPEAT STRIP_TAC >> ( + qexists_tac `n'` >> + rpt strip_tac >> ( fs [] ) ) >> -Q.EXISTS_TAC `ms''` >> -Q.EXISTS_TAC `n''` >> +qexists_tac `ms''` >> +qexists_tac `n''` >> fs [] >| [ QSPECL_X_ASSUM ``!(n':num). n' < n /\ n' > 0 ==> _`` [`n''`] >> rfs [], - REPEAT STRIP_TAC >> + rpt strip_tac >> QSPECL_X_ASSUM ``!(n'3':num). n'3' < n'' /\ n'3' > 0 ==> _`` [`n'3'`] >> rfs [] -] -); - -val weak_rel_steps_union = prove(`` - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' n n'. - weak_rel_steps m ms ls1 ms' n ==> - weak_rel_steps m ms ls2 ms'' n' ==> - n' < n ==> - weak_rel_steps m ms (ls1 UNION ls2) ms'' n' - ``, +] +QED -REPEAT STRIP_TAC >> +Theorem weak_rel_steps_union: + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' n n'. + weak_rel_steps m ms ls1 ms' n ==> + weak_rel_steps m ms ls2 ms'' n' ==> + n' < n ==> + weak_rel_steps m ms (ls1 UNION ls2) ms'' n' +Proof +rpt strip_tac >> fs [weak_rel_steps_def] >> -REPEAT STRIP_TAC >> +rpt strip_tac >> QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> rfs [] >> fs [] -); - -val weak_intermediate_labels = prove(`` - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - m.weak ms ls1 ms' ==> - ~(m.weak ms (ls1 UNION ls2) ms') ==> - ?ms''. (m.pc ms'') IN ls2 /\ m.weak ms (ls1 UNION ls2) ms'' - ``, +QED -REPEAT STRIP_TAC >> +Theorem weak_intermediate_labels: + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + m.weak ms ls1 ms' ==> + ~(m.weak ms (ls1 UNION ls2) ms') ==> + ?ms''. (m.pc ms'') IN ls2 /\ m.weak ms (ls1 UNION ls2) ms'' +Proof +rpt strip_tac >> PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> QSPECL_X_ASSUM ``!n. _`` [`n`] >> IMP_RES_TAC weak_rel_steps_intermediate_labels >> -Q.EXISTS_TAC `ms''` >> +qexists_tac `ms''` >> CONJ_TAC >| [ - METIS_TAC [weak_rel_steps_label], + metis_tac [weak_rel_steps_label], - METIS_TAC [weak_rel_steps_union] + metis_tac [weak_rel_steps_union] ] -); - -val FUNPOW_ASSOC = prove(`` -!f m n x. -FUNPOW f m (FUNPOW f n x) = FUNPOW f n (FUNPOW f m x)``, - -fs [GSYM arithmeticTheory.FUNPOW_ADD] -); - -val FUNPOW_SUB = prove(`` -!f m n x. -m > n ==> -FUNPOW f (m - n) (FUNPOW f n x) = FUNPOW f m x``, - -fs [GSYM arithmeticTheory.FUNPOW_ADD] -); - -val FUNPOW_OPT_split = prove(`` -!f n n' s s' s''. -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f (n + n') s = SOME s'' ==> -FUNPOW_OPT f n' s' = SOME s''``, - -METIS_TAC [FUNPOW_ASSOC, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] -); - -val FUNPOW_OPT_split2 = prove(`` -!f n' n s s'' s'. -n > n' ==> -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f n' s = SOME s'' ==> -FUNPOW_OPT f (n - n') s'' = SOME s'``, - -REPEAT STRIP_TAC >> -METIS_TAC [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] -); - -val FUNPOW_OPT_split3 = prove(`` -!f n' n s s'' s'. -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f (n + n') s = SOME s'' ==> -FUNPOW_OPT f n' s' = SOME s''``, - -cheat -); - -val FUNPOW_OPT_todoname = prove(`` -!f n n' n'' P ms ms_list. -FUNPOW_OPT_LIST f n ms = SOME (ms::ms_list) ==> -FUNPOW_OPT f n'' ms = - SOME - (EL (LENGTH (FILTER P ms_list) - 1) - (FILTER P ms_list)) ==> -n' < n - n'' ==> -FUNPOW_OPT f (n' + n'') ms = SOME (EL (PRE (n' + n'')) ms_list)``, - -REPEAT STRIP_TAC >> -fs [FUNPOW_OPT_LIST_EQ_SOME] >> -irule rich_listTheory.EL_CONS >> -fs [weak_rel_steps_def] >> -cheat -); - -val weak_rel_steps_FILTER_inter = prove(`` - !m. - weak_model m ==> - !ms ls ms' i i' i'' l ms_list ms_list'. - weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> - EL i' ms_list = EL i (FILTER (\ms. m.pc ms = l) ms_list) ==> - EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> - i < LENGTH ms_list' - 1 ==> - FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> - weak_rel_steps m (EL i ms_list') ({l} UNION ls) (EL (i + 1) ms_list') (i'' - i') - ``, - -cheat -); - -val weak_rel_steps_FILTER_end = prove(`` - !m. - weak_model m ==> - !ms ls ms' i i'' l ms_list ms_list'. - weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> - FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> - i < LENGTH ms_list' - 1 ==> - EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> - weak_rel_steps m (EL (i + 1) ms_list') ls ms' (LENGTH ms_list - SUC i'') - ``, - -cheat -); - -val weak_rel_steps_FILTER_NOTIN_end = prove(`` - !m. - weak_model m ==> - !ms ls ms' n n' l ms_list ms_list'. - weak_rel_steps m ms ls ms' n ==> - l NOTIN ls ==> - FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> - EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list) = EL n' ms_list ==> - SUC n' < n - ``, - -cheat -); - -val weak_rel_steps_unique = prove(`` - !m. - weak_model m ==> - !ms ls ms' ms'' n n'. - weak_rel_steps m ms ls ms' n ==> - weak_rel_steps m ms ls ms'' n' ==> - (ms' = ms'' /\ n = n') - ``, +QED -REPEAT STRIP_TAC >| [ - METIS_TAC [weak_rel_steps_imp, weak_unique_thm], +Theorem weak_rel_steps_unique: + !m. + weak_model m ==> + !ms ls ms' ms'' n n'. + weak_rel_steps m ms ls ms' n ==> + weak_rel_steps m ms ls ms'' n' ==> + (ms' = ms'' /\ n = n') +Proof +rpt strip_tac >| [ + metis_tac [weak_rel_steps_imp, weak_unique_thm], fs [weak_rel_steps_def] >> CCONTR_TAC >> @@ -1235,8 +344,12 @@ REPEAT STRIP_TAC >| [ ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls`` [`n'`] >> rfs [] ] -); +QED +(* If weak transition to ls connects ms to ms' via n transitions, then if for all + * numbers of transitions n' @@ -1247,49 +360,77 @@ val weak_rel_steps_intermediate_start = prove(`` weak_rel_steps m ms'' ls ms' (n - n') ``, -cheat +rpt strip_tac >> +fs [weak_rel_steps_def] >> +Cases_on `n'` >- ( + fs [FUNPOW_OPT_REWRS] +) >> +rpt strip_tac >| [ + irule FUNPOW_OPT_INTER >> + qexists_tac `ms` >> + qexists_tac `SUC n''` >> + fs [], + + QSPECL_X_ASSUM ``!n'. _`` [`SUC n'' + n'`] >> + rfs [] >> + metis_tac [FUNPOW_OPT_INTER] +] ); +*) +(* If weak transition to ls connects ms to ms' via n transitions, and ms'' to ms' + * via n-n' transitions, then if for all non-zero transitions n'' lower than n-n' + * ls' is not encountered, then + * weak transition to (ls' UNION ls) connects ms'' to ms' via n-n' transitions. *) +(* val weak_rel_steps_superset_after = prove(`` !m. weak_model m ==> - !ms ls ls' ms' ms'' n n'. - n' < n ==> + !ms ls ls' ms' n. weak_rel_steps m ms ls ms' n ==> - weak_rel_steps m ms'' ls ms' (n - n') ==> - (!n''. n'' < (n-n') ==> n'' > 0 ==> (?ms'''. FUNPOW_OPT m.trs n'' ms'' = SOME ms''' /\ m.pc ms''' NOTIN ls')) ==> - weak_rel_steps m ms'' (ls' UNION ls) ms' (n - n') +(* Note: this is exactly the second conjunct of weak_rel_steps *) + (!n'. n' < n /\ n' > 0 ==> (?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls')) ==> +(* TODO: This formulation also possible (end point must now also be in ls'): + weak_rel_steps m ms ls' ms' n' ==> +*) + weak_rel_steps m ms (ls UNION ls') ms' n ``, -cheat +rpt strip_tac >> +fs [weak_rel_steps_def] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> +QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> +rfs [] >> +fs [] ); +*) -val weak_rel_steps_intermediate_labels2 = prove(`` - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' n n'. - weak_rel_steps m ms ls2 ms' n ==> - ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> - weak_rel_steps m ms (ls1 UNION ls2) ms'' n' ==> - ?n''. weak_rel_steps m ms'' ls2 ms' n'' /\ n'' < n - ``, - -REPEAT STRIP_TAC >> +Theorem weak_rel_steps_intermediate_labels2: + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' n n'. + weak_rel_steps m ms ls2 ms' n ==> + ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> + weak_rel_steps m ms (ls1 UNION ls2) ms'' n' ==> + ?n''. weak_rel_steps m ms'' ls2 ms' n'' /\ n'' < n +Proof +rpt strip_tac >> subgoal `weak_rel_steps m ms (ls1 UNION ls2) ms'' n' /\ n' < n` >- ( subgoal `?ms'' n'. weak_rel_steps m ms (ls1 UNION ls2) ms'' n' /\ n' < n` >- ( - METIS_TAC [weak_rel_steps_intermediate_labels, weak_rel_steps_union, pred_setTheory.UNION_COMM] + metis_tac [weak_rel_steps_intermediate_labels, weak_rel_steps_union, pred_setTheory.UNION_COMM] ) >> - METIS_TAC [weak_rel_steps_unique] + metis_tac [weak_rel_steps_unique] ) >> fs [] >> fs [weak_rel_steps_def] >> rfs [] >> ( - Q.EXISTS_TAC `n - n'` >> + qexists_tac `n - n'` >> subgoal `FUNPOW_OPT m.trs (n - n') ms'' = SOME ms'` >- ( - METIS_TAC [FUNPOW_OPT_split2, arithmeticTheory.GREATER_DEF] + metis_tac [FUNPOW_OPT_split2, arithmeticTheory.GREATER_DEF] ) >> fs [] >> - REPEAT STRIP_TAC >> + rpt strip_tac >> QSPECL_X_ASSUM ``!n'. n' < n /\ n' > 0 ==> ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n' + n'3'`] >> @@ -1300,150 +441,208 @@ rfs [] >> ( fs [] ) >> fs [] >> - Q.EXISTS_TAC `ms'3'` >> + qexists_tac `ms'3'` >> fs [] >> - METIS_TAC [FUNPOW_OPT_split] + metis_tac [FUNPOW_OPT_INTER, arithmeticTheory.ADD_SYM] ) -); - -val weak_rel_steps_intermediate_labels3 = prove(`` - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' n n'. - weak_rel_steps m ms ls1 ms' n ==> - weak_rel_steps m ms (ls2 UNION ls1) ms'' n' ==> - n' < n ==> - m.pc ms'' IN ls2 - ``, +QED -REPEAT STRIP_TAC >> +Theorem weak_rel_steps_intermediate_labels3: + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' n n'. + weak_rel_steps m ms ls1 ms' n ==> + weak_rel_steps m ms (ls2 UNION ls1) ms'' n' ==> + n' < n ==> + m.pc ms'' IN ls2 +Proof +rpt strip_tac >> fs [weak_rel_steps_def] >> QSPECL_X_ASSUM ``!n'. n' < n /\ n' > 0 ==> ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> rfs [] -); +QED + +Theorem weak_intermediate_labels2: + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms''. + m.weak ms ls2 ms' ==> + ~(m.weak ms (ls1 UNION ls2) ms') ==> + m.weak ms (ls1 UNION ls2) ms'' ==> + m.weak ms'' ls2 ms' +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> +metis_tac [weak_rel_steps_intermediate_labels2] +QED -val weak_intermediate_labels2 = prove(`` +(* +val weak_rel_steps_FILTER_inter = prove(`` !m. weak_model m ==> - !ms ls1 ls2 ms' ms''. - m.weak ms ls2 ms' ==> - ~(m.weak ms (ls1 UNION ls2) ms') ==> - m.weak ms (ls1 UNION ls2) ms'' ==> - m.weak ms'' ls2 ms' + !ms ls ms' i i' i'' l ms_list ms_list'. + weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> + EL i' ms_list = EL i (FILTER (\ms. m.pc ms = l) ms_list) ==> + EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> + i < LENGTH ms_list' - 1 ==> + FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> + weak_rel_steps m (EL i ms_list') ({l} UNION ls) (EL (i + 1) ms_list') (i'' - i') ``, -REPEAT STRIP_TAC >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> -METIS_TAC [weak_rel_steps_intermediate_labels2] +rpt strip_tac >> +fs [FUNPOW_OPT_LIST_EQ_SOME] >> +(* TODO: Problem is, EL i' ms_list and EL i'' ms_list may not be unique in ms_list *) +cheat ); +*) -(* Definition of the triple *) -(* Pre and post usually have conditions on execution mode and code in memory *) -(* also post is usually a map that depends on the end state address *) -val abstract_partial_jgmt_def = Define ` - abstract_partial_jgmt m (l:'a) (ls:'a->bool) pre post = - !ms ms'. - ((m.pc ms) = l) ==> - pre ms ==> - m.weak ms ls ms' ==> - post ms' -`; - -val abstract_jgmt_imp_partial_triple = - store_thm("abstract_jgmt_imp_partial_triple", - ``!m l ls pre post. - weak_model m ==> - abstract_jgmt m l ls pre post ==> - abstract_partial_jgmt m l ls pre post``, - -FULL_SIMP_TAC std_ss [abstract_jgmt_def, abstract_partial_jgmt_def] >> -REPEAT STRIP_TAC >> -QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> -METIS_TAC [weak_unique_thm] -); +(* +val weak_rel_steps_FILTER_end = prove(`` + !m. + weak_model m ==> + !ms ls ms' i i'' l ms_list ms_list'. + weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> + FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> + i < LENGTH ms_list' - 1 ==> + EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> + weak_rel_steps m (EL (i + 1) ms_list') ls ms' (LENGTH ms_list - SUC i'') + ``, -val weak_partial_case_rule_thm = prove(`` -!m l ls pre post C1. - abstract_partial_jgmt m l ls (\ms. (pre ms) /\ (C1 ms)) post ==> - abstract_partial_jgmt m l ls (\ms. (pre ms) /\ (~(C1 ms))) post ==> - abstract_partial_jgmt m l ls pre post -``, +rpt strip_tac >> +irule weak_rel_steps_intermediate_start >> +fs [] >> +CONJ_TAC >| [ + (* TODO: SUC i'' < LENGTH ms_list from main proof goal? *) + cheat, -REPEAT STRIP_TAC >> -FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -METIS_TAC [] + qexists_tac `ms` >> + fs [] >> + (* TODO: Should be OK if we have SUC i'' < LENGTH ms_list *) + cheat +] ); - -val weak_partial_weakening_rule_thm = - store_thm("weak_partial_weakening_rule_thm", - ``!m. - !l ls pre1 pre2 post1 post2. - weak_model m ==> - (!ms. ((m.pc ms) = l) ==> (pre2 ms) ==> (pre1 ms)) ==> - (!ms. ((m.pc ms) IN ls) ==> (post1 ms) ==> (post2 ms)) ==> - abstract_partial_jgmt m l ls pre1 post1 ==> - abstract_partial_jgmt m l ls pre2 post2 +*) +(* +val weak_rel_steps_FILTER_NOTIN_end = prove(`` + !m. + weak_model m ==> + !ms ls ms' n n' l ms_list ms_list'. + weak_rel_steps m ms ls ms' n ==> + l NOTIN ls ==> + FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> + EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list) = EL n' ms_list ==> + SUC n' < n ``, -SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -REPEAT STRIP_TAC >> -METIS_TAC [weak_pc_in_thm] +rpt strip_tac >> +(* TODO: Unclear? *) +cheat ); +*) + + +Definition abstract_partial_jgmt_def: + abstract_partial_jgmt m (l:'a) (ls:'a->bool) pre post = + !ms ms'. + ((m.pc ms) = l) ==> + pre ms ==> + m.weak ms ls ms' ==> + post ms' +End -val weak_partial_subset_rule_thm = - store_thm("weak_partial_subset_rule_thm", - ``!m. ! l ls1 ls2 pre post . - weak_model m ==> - (!ms. post ms ==> (~(m.pc ms IN ls2))) ==> - abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> - abstract_partial_jgmt m l ls1 pre post``, +Theorem abstract_jgmt_imp_partial_triple: + !m l ls pre post. + weak_model m ==> + abstract_jgmt m l ls pre post ==> + abstract_partial_jgmt m l ls pre post +Proof +FULL_SIMP_TAC std_ss [abstract_jgmt_def, abstract_partial_jgmt_def] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> +metis_tac [weak_unique_thm] +QED + +Theorem weak_partial_case_rule_thm: + !m l ls pre post C1. + abstract_partial_jgmt m l ls (\ms. (pre ms) /\ (C1 ms)) post ==> + abstract_partial_jgmt m l ls (\ms. (pre ms) /\ (~(C1 ms))) post ==> + abstract_partial_jgmt m l ls pre post +Proof +rpt strip_tac >> +FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +metis_tac [] +QED -REPEAT STRIP_TAC >> +Theorem weak_partial_weakening_rule_thm: + !m. + !l ls pre1 pre2 post1 post2. + weak_model m ==> + (!ms. ((m.pc ms) = l) ==> (pre2 ms) ==> (pre1 ms)) ==> + (!ms. ((m.pc ms) IN ls) ==> (post1 ms) ==> (post2 ms)) ==> + abstract_partial_jgmt m l ls pre1 post1 ==> + abstract_partial_jgmt m l ls pre2 post2 +Proof +SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +rpt strip_tac >> +metis_tac [weak_pc_in_thm] +QED + +Theorem weak_partial_subset_rule_thm: + !m. !l ls1 ls2 pre post. + weak_model m ==> + (!ms. post ms ==> (~(m.pc ms IN ls2))) ==> + abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> + abstract_partial_jgmt m l ls1 pre post +Proof +rpt strip_tac >> rfs [abstract_partial_jgmt_def] >> -REPEAT STRIP_TAC >> +rpt strip_tac >> QSPECL_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> rfs [] >> Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( fs [] ) >> subgoal `?n. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( - METIS_TAC [weak_model_def] + metis_tac [weak_model_def] ) >> IMP_RES_TAC weak_intermediate_labels >> QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms''`] >> rfs [] >> -METIS_TAC [] -); +metis_tac [] +QED -val weak_partial_conj_rule_thm = prove(`` +Theorem weak_partial_conj_rule_thm: !m. weak_model m ==> !l ls pre post1 post2. abstract_partial_jgmt m l ls pre post1 ==> abstract_partial_jgmt m l ls pre post2 ==> - abstract_partial_jgmt m l ls pre (\ms. (post1 ms) /\ (post2 ms))``, - -REPEAT STRIP_TAC >> + abstract_partial_jgmt m l ls pre (\ms. (post1 ms) /\ (post2 ms)) +Proof +rpt strip_tac >> FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -REPEAT STRIP_TAC >> -METIS_TAC [weak_unique_thm] -); - +rpt strip_tac >> +metis_tac [weak_unique_thm] +QED -val weak_partial_seq_rule_thm = store_thm("weak_partial_seq_rule_thm", - ``!m l ls1 ls2 pre post. - weak_model m ==> - abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> - (!l1. (l1 IN ls1) ==> - (abstract_partial_jgmt m l1 ls2 post post)) ==> - abstract_partial_jgmt m l ls2 pre post``, -REPEAT STRIP_TAC >> +Theorem weak_partial_seq_rule_thm: + !m l ls1 ls2 pre post. + weak_model m ==> + abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> + (!l1. (l1 IN ls1) ==> + (abstract_partial_jgmt m l1 ls2 post post)) ==> + abstract_partial_jgmt m l ls2 pre post +Proof +rpt strip_tac >> FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -REPEAT STRIP_TAC >> +rpt strip_tac >> QSPECL_X_ASSUM ``!ms ms'. (m.pc ms = l) ==> pre ms ==> @@ -1451,27 +650,163 @@ QSPECL_X_ASSUM ``!ms ms'. post ms'`` [`ms`] >> rfs [] >> subgoal `(m.pc ms') IN ls2` >- ( - METIS_TAC [weak_pc_in_thm] + metis_tac [weak_pc_in_thm] ) >> Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( - METIS_TAC [] + metis_tac [] ) >> subgoal `?ms''. m.pc ms'' IN ls1 /\ m.weak ms (ls2 UNION ls1) ms''` >- ( - METIS_TAC [weak_intermediate_labels, pred_setTheory.UNION_COMM] + metis_tac [weak_intermediate_labels, pred_setTheory.UNION_COMM] ) >> QSPECL_X_ASSUM ``!l1. l1 IN ls1 ==> _`` [`m.pc ms''`] >> rfs [] >> QSPECL_X_ASSUM ``!ms ms'. _`` [`ms''`, `ms'`] >> rfs [] >> subgoal `post ms''` >- ( - METIS_TAC [pred_setTheory.UNION_COMM] + metis_tac [pred_setTheory.UNION_COMM] ) >> -METIS_TAC [pred_setTheory.UNION_COMM, weak_intermediate_labels2] -); +metis_tac [pred_setTheory.UNION_COMM, weak_intermediate_labels2] +QED + + +Theorem weak_rel_steps_list_states_subgoal_2_lemma: +!m n ms ms' ms_list ls l. + weak_model m ==> + n > 0 ==> + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> + l NOTIN ls ==> + FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> + FILTER (\ms. m.pc ms = l) ms_list = [] ==> + INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list = + SOME (PRE n,ms') +Proof +rpt strip_tac >> +Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) = (\ms''. (\ms'''. m.pc ms''' IN ls) ms'' \/ (\ms'''. m.pc ms''' IN {l}) ms'')` (fn thm => REWRITE_TAC [thm]) >- ( + fs [] >> + metis_tac [] +) >> +irule FUNPOW_OPT_LIST_FILTER_NULL >> +fs [] >> +metis_tac [] +QED + +Theorem weak_rel_steps_list_states_subgoal_3_lemma: +!m n ms ms' ms_list ls l. + weak_model m ==> + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> + l NOTIN ls ==> + FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> + LENGTH (FILTER (\ms. m.pc ms = l) ms_list) > 0 ==> + ?n'. + (n' > 0 /\ + ?ms_list'. + FUNPOW_OPT_LIST m.trs n' ms = SOME (ms::ms_list') /\ + INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list' = + SOME (PRE n',HD (FILTER (\ms. m.pc ms = l) ms_list))) /\ + (n > n' /\ + ?ms_list'. + FUNPOW_OPT_LIST m.trs (n - n') + (HD (FILTER (\ms. m.pc ms = l) ms_list)) = + SOME (HD (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list' = + SOME (PRE (n - n'),ms')) /\ n' < n /\ n' > 0 +Proof +rpt strip_tac >> +Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) = (\ms''. (\ms'''. m.pc ms''' IN {l}) ms'' \/ (\ms'''. m.pc ms''' IN ls) ms'')` (fn thm => REWRITE_TAC [thm]) >- ( + fs [] >> + metis_tac [] +) >> +Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l) = (\ms'3'. m.pc ms'3' IN {l})` (fn thm => REWRITE_TAC [thm]) >- ( + fs [] >> + metis_tac [] +) >> +irule FUNPOW_OPT_LIST_FILTER_FIRST >> +fs [] >> +subgoal `ms' = LAST ms_list` >- ( + fs [INDEX_FIND_EQ_SOME_0] >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + rw [] >> + ONCE_REWRITE_TAC [EQ_SYM_EQ] >> + irule listTheory.LAST_EL >> + (* TODO: Find nice lemma for this... *) + Cases_on `ms_list` >> ( + fs [] + ) +) >> +fs [INDEX_FIND_EQ_SOME_0] >> +metis_tac [IN_NOT_IN_NEQ_thm] +QED + +Theorem weak_rel_steps_list_states_subgoal_4_lemma: +!m n ms ms' ms_list ls l. + weak_model m ==> + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> + l NOTIN ls ==> + FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> + LENGTH (FILTER (\ms. m.pc ms = l) ms_list) > 0 ==> + ?n''. + (?ms_list'. + FUNPOW_OPT_LIST m.trs n'' + (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) + (FILTER (\ms. m.pc ms = l) ms_list)) = + SOME + (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) + (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ + INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list' = + SOME (PRE n'',ms')) /\ n'' > 0 +Proof +rpt strip_tac >> +subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( + fs [] +) >> +Q.SUBGOAL_THEN `EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) + (FILTER (\ms. m.pc ms = l) ms_list) = LAST ms_list'` (fn thm => REWRITE_TAC [thm]) >- ( + (* By listTheory.LAST_EL *) + fs [] >> + ONCE_REWRITE_TAC [EQ_SYM_EQ] >> + ONCE_REWRITE_TAC [GSYM arithmeticTheory.PRE_SUB1] >> + irule listTheory.LAST_EL >> + fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] +) >> +Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) = (\ms''. (\ms'''. m.pc ms''' IN {l}) ms'' \/ (\ms'''. m.pc ms''' IN ls) ms'')` (fn thm => REWRITE_TAC [thm]) >- ( + fs [] >> + metis_tac [] +) >> +irule FUNPOW_OPT_LIST_FILTER_LAST >> +fs [] >> +qexists_tac `n` >> +qexists_tac `ms` >> +qexists_tac `ms_list` >> +fs [] +QED + +Theorem weak_rel_steps_list_states_subgoal_5_lemma: +!m n ms ms' ms_list ls l i. + weak_model m ==> + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> + l NOTIN ls ==> + FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> + i < LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1 ==> + ?n' n''. + (?ms_list'. + FUNPOW_OPT_LIST m.trs n' + (EL i (FILTER (\ms. m.pc ms = l) ms_list)) = + SOME (EL i (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ + INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list' = + SOME (PRE n',EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list))) /\ + (?ms_list'. + FUNPOW_OPT_LIST m.trs n'' + (EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list)) = + SOME (EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ + INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list' = SOME (PRE n'',ms')) /\ + n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0 +Proof +metis_tac [FUNPOW_OPT_LIST_FILTER_BETWEEN] +QED (* This describes the necessary characteristics of the list ms_list, which consists of * all states where l is encountered between ms and ms'. *) -val weak_rel_steps_list_states = prove(`` +Theorem weak_rel_steps_list_states: !m ms l ls ms' n. weak_model m ==> weak_rel_steps m ms ls ms' n ==> @@ -1486,9 +821,8 @@ val weak_rel_steps_list_states = prove(`` !i. (i < ((LENGTH ms_list) - 1) ==> ?n' n''. weak_rel_steps m (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list) n' /\ weak_rel_steps m (EL (i+1) ms_list) ls ms' n'' /\ n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0)) -``, - -REPEAT STRIP_TAC >> +Proof +rpt strip_tac >> subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( fs [weak_rel_steps_def] >> IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> @@ -1506,68 +840,41 @@ subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( ) ) >> subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n' ms'' = SOME ms_list` >- ( - METIS_TAC [FUNPOW_OPT_LIST_BACK_PRE] + metis_tac [FUNPOW_OPT_LIST_BACK_PRE] ) >> - Q.EXISTS_TAC `ms_list` >> + qexists_tac `ms_list` >> (* TODO: Should be OK... * (see also first subgoal in weak_rel_steps_smallest_exists, reuse this?) *) IMP_RES_TAC FUNPOW_OPT_LIST_BACK_INCR >> fs [] -(* OLD - irule FUNPOW_OPT_LIST_EXISTS >> - Q.EXISTS_TAC `n` >> - fs [] -*) -) >> -(* -REPEAT STRIP_TAC >> -subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME ms_list` >- ( - (* OK: Contradicts weak_rel_steps m ms ls ms' n otherwise *) - fs [weak_rel_steps_def] >> - irule FUNPOW_OPT_LIST_EXISTS >> - fs [] >> - Q.EXISTS_TAC `n` >> - fs [] ) >> -*) -Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> -REPEAT STRIP_TAC >| [ - (* subgoal 1. OK: Element in filtered list obeys filter property *) +qexists_tac `FILTER (\ms. m.pc ms = l) ms_list` >> +rpt strip_tac >| [ + (* subgoal 1. OK: by FILTER_MEM *) subgoal `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list))` >- ( (* TODO: Silly, but it works... *) `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list)) /\ MEM (EL i (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` suffices_by ( fs [] ) >> irule FILTER_MEM >> - Q.EXISTS_TAC `FILTER (\ms. m.pc ms = l) ms_list` >> - METIS_TAC [listTheory.MEM_EL] + qexists_tac `FILTER (\ms. m.pc ms = l) ms_list` >> + metis_tac [listTheory.MEM_EL] ) >> fs [], - (* subgoal 2. OK: If filtered list is empty, l can be inserted in ending label set *) - fs [weak_rel_steps_def] >> - REPEAT STRIP_TAC >> - subgoal `?ms''. FUNPOW_OPT m.trs n' ms = SOME ms''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL_SOME] - ) >> - fs [listTheory.FILTER_EQ_NIL] >> - subgoal `EL (PRE n') ms_list = ms''` >- ( - subgoal `(EL n' (ms::ms_list)) = ms''` >- ( - METIS_TAC [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] - ) >> - METIS_TAC [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] - ) >> - fs [listTheory.EVERY_EL] >> - QSPECL_X_ASSUM ``!n. _`` [`PRE n'`] >> - QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> - fs [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - rfs [], + (* subgoal 2. OK: If filtered list is empty, l can be inserted in ending label set + * See FUNPOW_OPT_LIST_FILTER_NULL *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> + metis_tac [weak_rel_steps_list_states_subgoal_2_lemma], (* subgoal 3. OK: First encounter of l is reached when filtered list is non-empty, - * also weak transition can proceed from there directly to ending label set *) + * also weak transition can proceed from there directly to ending label set + * See FUNPOW_OPT_LIST_FILTER_FIRST *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> + metis_tac [weak_rel_steps_list_states_subgoal_3_lemma], +(* OLD: subgoal `?ms''. ms'' = EL 0 (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - METIS_TAC [] + metis_tac [] ) >> (* TODO: The below is used in multiple subgoals... *) subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( @@ -1579,18 +886,22 @@ REPEAT STRIP_TAC >| [ fs [FUNPOW_OPT_LIST_EQ_SOME] >> IMP_RES_TAC FILTER_MEM >> QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> MEM x ms_list`` [`ms''`] >> - rfs [MEM_HD] >> + Q.SUBGOAL_THEN `MEM (HD ms_list') ms_list'` (fn thm => rfs [thm]) >- ( + rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) >> fs [listTheory.MEM_EL] >> - Q.EXISTS_TAC `n'` >> + qexists_tac `n'` >> fs [listTheory.oEL_THM] ) >> - Q.EXISTS_TAC `i` >> + qexists_tac `i` >> fs [listTheory.oEL_EQ_EL, FUNPOW_OPT_LIST_EQ_SOME] >> Cases_on `i = PRE n` >- ( subgoal `m.pc ms'' = l` >- ( IMP_RES_TAC FILTER_MEM >> QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> (\ms. m.pc ms = l) x`` [`ms''`] >> - rfs [MEM_HD] + Q.SUBGOAL_THEN `MEM (HD ms_list') ms_list'` (fn thm => rfs [thm]) >- ( + rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) ) >> fs [weak_rel_steps_def] >> subgoal `ms'' = ms'` >- ( @@ -1603,7 +914,7 @@ REPEAT STRIP_TAC >| [ ) >> subgoal `PRE (LENGTH (ms::ms_list)) = n` >- ( SIMP_TAC list_ss [] >> - METIS_TAC [] + metis_tac [] ) >> fs [rich_listTheory.EL_CONS, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] ) >> @@ -1611,20 +922,22 @@ REPEAT STRIP_TAC >| [ ) >> fs [] ) >> - Q.EXISTS_TAC `SUC i` >> + qexists_tac `SUC i` >> fs [] >> - REPEAT STRIP_TAC >| [ + rpt strip_tac >| [ (* subgoal 3a. OK: SUC i steps taken until first encounter of l * EL i ms_list = HD ms_list' is among assumptions *) fs [weak_rel_steps_def] >> - REPEAT STRIP_TAC >| [ + rpt strip_tac >| [ (* HD ms_list' reached in SUC i steps from ms *) fs [FUNPOW_OPT_LIST_EQ_SOME], (* HD ms_list' is either l or in ls *) IMP_RES_TAC FILTER_MEM >> QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> (\ms. m.pc ms = l) x`` [`HD ms_list'`] >> - rfs [MEM_HD], + Q.SUBGOAL_THEN `MEM (HD ms_list') ms_list'` (fn thm => rfs [thm]) >- ( + rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ), (* At n' < SUC i steps, we are neither at l nor in ls *) QSPECL_X_ASSUM ``!n'. @@ -1636,8 +949,8 @@ REPEAT STRIP_TAC >| [ fs [] ) >> irule FILTER_NOT_MEM >> - Q.EXISTS_TAC `ms_list` >> - Q.EXISTS_TAC `ms_list'` >> + qexists_tac `ms_list` >> + qexists_tac `ms_list'` >> fs [FUNPOW_OPT_LIST_EQ_SOME] >> (* OK: ms'3' is in ms_list (since n' < n) but not in ms_list' (since n' < SUC i, so before first encounter) *) CONJ_TAC >| [ @@ -1645,9 +958,9 @@ REPEAT STRIP_TAC >| [ QSPECL_X_ASSUM ``!i'. i' < i ==> ~MEM (EL i' ms_list) ms_list'`` [`PRE n'`] >> rfs [] >> `EL (PRE n') ms_list = ms'3'` suffices_by ( - METIS_TAC [] + metis_tac [] ) >> - METIS_TAC [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF], + metis_tac [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF], QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`n'`] >> rfs [] >> @@ -1659,54 +972,59 @@ REPEAT STRIP_TAC >| [ (* subgoal 3b. OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) irule weak_rel_steps_intermediate_start >> fs [] >> - Q.EXISTS_TAC `ms` >> + qexists_tac `ms` >> fs [FUNPOW_OPT_LIST_EQ_SOME] ], +*) (* subgoal 4. OK: Last element in filtered list can perform weak transition with ending * label set ({l} UNION ls) and reach ms' *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> + metis_tac [weak_rel_steps_list_states_subgoal_4_lemma], +(* OLD: subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( fs [] ) >> subgoal `MEM (EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` >- ( subgoal `MEM (EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( fs [listTheory.MEM_EL] >> - Q.EXISTS_TAC `PRE (LENGTH ms_list')` >> + qexists_tac `PRE (LENGTH ms_list')` >> fs [] ) >> - METIS_TAC [FILTER_MEM] + metis_tac [FILTER_MEM] ) >> (* Note : this introduces n'3', the number of transitions to last encounter of l. *) subgoal `?n'''. FUNPOW_OPT m.trs n''' ms = SOME (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) (FILTER (\ms. m.pc ms = l) ms_list)) /\ n''' < n /\ n''' > 0` >- ( fs [listTheory.MEM_EL] >> - Q.EXISTS_TAC `SUC n'` >> - REPEAT CONJ_TAC >| [ + qexists_tac `SUC n'` >> + rpt CONJ_TAC >| [ fs [FUNPOW_OPT_LIST_EQ_SOME, arithmeticTheory.PRE_SUB1] >> rw [], (* TODO: Last element of ms_list' not being in l contradiction *) - METIS_TAC [weak_rel_steps_FILTER_NOTIN_end], + metis_tac [weak_rel_steps_FILTER_NOTIN_end], fs [] ] ) >> IMP_RES_TAC weak_rel_steps_intermediate_start >> - Q.EXISTS_TAC `n - n'3'` >> + qexists_tac `n - n'3'` >> fs [] >> + ONCE_REWRITE_TAC [pred_setTheory.UNION_COMM] >> irule weak_rel_steps_superset_after >> - REPEAT STRIP_TAC >> ( + rpt strip_tac >> ( fs [] ) >| [ (* Find appropriate index in ms_list and use it, also lemma that indices after FILTER LAST do * not have label l *) - Q.EXISTS_TAC `EL (PRE (n'' + n'3')) ms_list` >> + qexists_tac `EL (PRE (n' + n'3')) ms_list` >> CONJ_TAC >| [ (* TODO: Lemma for this situation *) - irule FUNPOW_OPT_split3 >> - Q.EXISTS_TAC `n'3'` >> - Q.EXISTS_TAC `ms` >> + irule FUNPOW_OPT_split >> + qexists_tac `n'3'` >> + qexists_tac `ms` >> fs [] >> - METIS_TAC [FUNPOW_OPT_todoname], + metis_tac [FUNPOW_OPT_todoname], (* subgoal `n'3' < n` >- ( @@ -1730,11 +1048,11 @@ REPEAT STRIP_TAC >| [ fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] ) >> IMP_RES_TAC FILTER_AFTER >> - QSPECL_X_ASSUM ``!i'. i' > PRE n'3' ==> ~(\ms. m.pc ms = l) (EL i' ms_list)`` [`(PRE (n'' + n'3'))`] >> - `PRE (n'' + n'3') > PRE n'3'` suffices_by ( + QSPECL_X_ASSUM ``!i'. i' > PRE n'3' ==> ~(\ms. m.pc ms = l) (EL i' ms_list)`` [`(PRE (n' + n'3'))`] >> + `PRE (n' + n'3') > PRE n'3'` suffices_by ( fs [] ) >> - Cases_on `n''` >- ( + Cases_on `n'` >- ( fs [] ) >> Cases_on `n'3'` >> ( @@ -1742,14 +1060,17 @@ REPEAT STRIP_TAC >| [ ) ], - METIS_TAC [], - - METIS_TAC [] + metis_tac [] ], +*) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> + metis_tac [weak_rel_steps_list_states_subgoal_5_lemma] (* subgoal 5. Inductive case for weak transition with ending label set ({l} UNION ls) * between elements of the list (where the latter point goes to ms' with ending label set ls). * Should also be OK *) + +(* OLD subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( fs [] ) >> @@ -1758,7 +1079,7 @@ REPEAT STRIP_TAC >| [ fs [rich_listTheory.EL_MEM] ) >> fs [listTheory.MEM_FILTER, listTheory.MEM_EL] >> - Q.EXISTS_TAC `n'` >> + qexists_tac `n'` >> rw [] ) >> subgoal `?i'. EL i' ms_list = EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list) /\ i' < LENGTH ms_list` >- ( @@ -1766,28 +1087,28 @@ REPEAT STRIP_TAC >| [ fs [rich_listTheory.EL_MEM] ) >> fs [listTheory.MEM_FILTER, listTheory.MEM_EL] >> - Q.EXISTS_TAC `n'` >> + qexists_tac `n'` >> rw [] ) >> subgoal `i' < i''` >- ( irule FILTER_ORDER >> - Q.EXISTS_TAC `(\ms. m.pc ms = l)` >> - Q.EXISTS_TAC `i` >> - Q.EXISTS_TAC `ms_list` >> + qexists_tac `(\ms. m.pc ms = l)` >> + qexists_tac `i` >> + qexists_tac `ms_list` >> fs [arithmeticTheory.ADD1] ) >> subgoal `n = LENGTH ms_list` >- ( fs [FUNPOW_OPT_LIST_EQ_SOME] ) >> - Q.EXISTS_TAC `SUC i'' - SUC i'` >> - Q.EXISTS_TAC `n - (SUC i'')` >> + qexists_tac `SUC i'' - SUC i'` >> + qexists_tac `n - (SUC i'')` >> fs [] >> - REPEAT STRIP_TAC >| [ + rpt strip_tac >| [ (* Weak transtion to ({l} UNION ls) between element i and element i+1 in ms_list' *) - METIS_TAC [weak_rel_steps_FILTER_inter], + metis_tac [weak_rel_steps_FILTER_inter], (* Weak transtion to ls between element i+1 and LAST of ms_list' *) - METIS_TAC [weak_rel_steps_FILTER_end], + metis_tac [weak_rel_steps_FILTER_end], (* Phrased differently: "Why can't a member of ms_list' be the last element in ms_list?" *) (* TODO: Last element of ms_list' not being in l contradiction *) @@ -1796,7 +1117,7 @@ REPEAT STRIP_TAC >| [ subgoal `m.pc (EL i'' ms_list) = l` >- ( subgoal `MEM (EL i'' ms_list) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( fs [listTheory.MEM_EL] >> - Q.EXISTS_TAC `i + 1` >> + qexists_tac `i + 1` >> fs [] ) >> fs [listTheory.MEM_FILTER] @@ -1804,33 +1125,34 @@ REPEAT STRIP_TAC >| [ subgoal `ms' = EL i'' ms_list` >- ( fs [FUNPOW_OPT_LIST_EQ_SOME, listTheory.LAST_EL] >> - METIS_TAC [listTheory.EL_restricted] + metis_tac [listTheory.EL_restricted] ) >> - METIS_TAC [] + metis_tac [] ) >> fs [] ] +*) ] -); +QED -val weak_partial_loop_contract_def = Define ` +Definition weak_partial_loop_contract_def: weak_partial_loop_contract m l le invariant C1 = (l NOTIN le /\ abstract_partial_jgmt m l ({l} UNION le) (\ms. invariant ms /\ C1 ms) (\ms. m.pc ms = l /\ invariant ms)) -`; -(* TODO: Preliminaries for proving partial loop rule *) -val weak_partial_loop_rule_thm = store_thm("weak_partial_loop_rule_thm", - ``!m. - weak_model m ==> - !l le invariant C1 var post. - weak_partial_loop_contract m l le invariant C1 ==> - abstract_partial_jgmt m l le (\ms. invariant ms /\ ~(C1 ms)) post ==> - abstract_partial_jgmt m l le invariant post``, - -REPEAT STRIP_TAC >> +End + +Theorem weak_partial_loop_rule_thm: + !m. + weak_model m ==> + !l le invariant C1 var post. + weak_partial_loop_contract m l le invariant C1 ==> + abstract_partial_jgmt m l le (\ms. invariant ms /\ ~(C1 ms)) post ==> + abstract_partial_jgmt m l le invariant post +Proof +rpt strip_tac >> fs [abstract_partial_jgmt_def, weak_partial_loop_contract_def] >> -REPEAT STRIP_TAC >> +rpt strip_tac >> PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> IMP_RES_TAC weak_rel_steps_list_states >> (* QSPECL_X_ASSUM ``!l. ?ms_list. _`` [`l`] >> *) @@ -1841,9 +1163,9 @@ Cases_on `ms_list = []` >- ( QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> rfs [] >> Cases_on `C1 ms` >| [ - METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp], + metis_tac [weak_pc_in_thm, weak_rel_steps_imp], - METIS_TAC [] + metis_tac [] ] ) >> subgoal `LENGTH ms_list > 0` >- ( @@ -1851,11 +1173,11 @@ subgoal `LENGTH ms_list > 0` >- ( ) >> fs [] >> Cases_on `~C1 ms` >- ( - METIS_TAC [] + metis_tac [] ) >> fs [] >> subgoal `m.pc ms' <> l` >- ( - METIS_TAC [weak_pc_in_thm, weak_rel_steps_imp] + metis_tac [weak_pc_in_thm, weak_rel_steps_imp] ) >> subgoal `!i. i < LENGTH ms_list ==> (invariant (EL i ms_list) \/ post ms') /\ @@ -1865,18 +1187,18 @@ subgoal `!i. i < LENGTH ms_list ==> QSPECL_X_ASSUM ``!i. _`` [`0`] >> subgoal `invariant (EL 0 ms_list)` >- ( fs [] >> - METIS_TAC [weak_rel_steps_intermediate_labels3, pred_setTheory.IN_SING] + metis_tac [weak_rel_steps_intermediate_labels3, pred_setTheory.IN_SING] ) >> fs [] >> Cases_on `C1 (HD ms_list)` >> ( fs [] ) >> PAT_X_ASSUM ``!ms ms'. _`` (fn thm => irule thm) >> - Q.EXISTS_TAC `HD ms_list` >> + qexists_tac `HD ms_list` >> fs [] >> - METIS_TAC [] + metis_tac [] ) >> - REPEAT STRIP_TAC >> ( + rpt strip_tac >> ( fs [] ) >| [ QSPECL_X_ASSUM ``!ms'' ms'3'. @@ -1892,7 +1214,7 @@ subgoal `!i. i < LENGTH ms_list ==> `?n. weak_rel_steps m (EL i ms_list) ({l} UNION le) (EL (SUC i) ms_list) n` suffices_by ( fs [] ) >> - Q.EXISTS_TAC `n'3'` >> + qexists_tac `n'3'` >> fs [arithmeticTheory.SUC_ONE_ADD], Cases_on `C1 (EL (SUC i) ms_list)` >> ( @@ -1902,26 +1224,26 @@ subgoal `!i. i < LENGTH ms_list ==> QSPECL_X_ASSUM ``!i. _`` [`i`] >> QSPECL_X_ASSUM ``!i. _`` [`i`] >> rfs [arithmeticTheory.SUC_ONE_ADD] >> - METIS_TAC [] + metis_tac [] ) >> PAT_X_ASSUM ``!ms ms'. _`` (fn thm => irule thm) >> QSPECL_X_ASSUM ``!i. _`` [`i`] >> Cases_on `SUC i = LENGTH ms_list - 1` >- ( (* SUC i is last in ms_list *) QSPECL_X_ASSUM ``!i. _`` [`SUC i`] >> - Q.EXISTS_TAC `EL (SUC i) ms_list` >> + qexists_tac `EL (SUC i) ms_list` >> fs [] >> rfs [] >> PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_rel_steps_equiv thm)]) >> - METIS_TAC [weak_union_thm, pred_setTheory.IN_SING, weak_rel_steps_equiv] + metis_tac [weak_union_thm, pred_setTheory.IN_SING, weak_rel_steps_equiv] ) >> subgoal `SUC i < LENGTH ms_list - 1` >- ( fs [] ) >> fs [] >> - Q.EXISTS_TAC `EL (SUC i) ms_list` >> + qexists_tac `EL (SUC i) ms_list` >> fs [arithmeticTheory.SUC_ONE_ADD] >> - METIS_TAC [] + metis_tac [] ] ) >> QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> @@ -1930,7 +1252,7 @@ subgoal `MEM (EL (LENGTH ms_list − 1) ms_list) ms_list` >- ( subgoal `LENGTH ms_list − 1 < LENGTH ms_list` >- ( fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] ) >> - METIS_TAC [rich_listTheory.EL_MEM] + metis_tac [rich_listTheory.EL_MEM] ) >> rfs [] >> Cases_on `C1 (EL (LENGTH ms_list − 1) ms_list)` >> ( @@ -1941,6 +1263,6 @@ Cases_on `C1 (EL (LENGTH ms_list − 1) ms_list)` >> ( rfs [] >> fs [] ) -); +QED val _ = export_theory(); From ee7d519756577178125ddf68c91559cd25aa2600 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Wed, 11 May 2022 02:26:37 +0200 Subject: [PATCH 0097/1015] Fixed some cheats in abstract_hoare_logic_auxScript --- .../abstract_hoare_logic_auxScript.sml | 113 ++++++++++++------ .../abstract_hoare_logic_partialScript.sml | 107 +---------------- 2 files changed, 77 insertions(+), 143 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index 3c6fb0907..c4debf047 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -118,19 +118,22 @@ fs [listTheory.MEM_FILTER] QED *) -(* TODO: Since l can have duplicate elements, we need to make sure +Theorem FILTER_OLEAST_HD: + !P l l'. + FILTER P l = l' ==> + LENGTH l' > 0 ==> + ?i. (OLEAST i. oEL i l = SOME (HD l')) = SOME i +Proof +cheat +QED + +(* Note: Since l can have duplicate elements, we need to make sure * EL i l is the FIRST encounter of HD l' in l. *) -(* TODO: Might require list nonempty or OLEAST... *) Theorem FILTER_BEFORE: -(* -!P l l' i. -FILTER P l = l' ==> -EL i l = HD l' ==> -(!i'. i' < i ==> ~P (EL i l) /\ ~MEM (EL i' l) l') -*) !P l l' i. FILTER P l = l' ==> - (LEAST i. EL i l = HD l') = i ==> + LENGTH l' > 0 ==> + (OLEAST i. oEL i l = SOME (HD l')) = SOME i ==> (!i'. i' < i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') Proof cheat @@ -839,7 +842,15 @@ Theorem FUNPOW_OPT_LIST_EXISTS_nicer: !f n n' x x'. FUNPOW_OPT f n x = SOME x' ==> n' <= n ==> - ?l. FUNPOW_OPT_LIST f n' x = SOME (x::(SNOC x' l)) + ?l. FUNPOW_OPT_LIST f n' x = SOME (x::l) +Proof +cheat +QED + +Theorem FUNPOW_OPT_LIST_EXISTS_exact: + !f n x x'. + FUNPOW_OPT f n x = SOME x' ==> + ?l. FUNPOW_OPT_LIST f n x = SOME (x::(SNOC x' l)) Proof cheat QED @@ -1060,41 +1071,39 @@ subgoal `?x_list'. FILTER P' x_list = x_list'` >- ( fs [] ) >> subgoal `LENGTH x_list > 0` >- ( - cheat + fs [INDEX_FIND_EQ_SOME_0] ) >> -subgoal `?i. x'' = EL i x_list /\ i < (PRE n)` >- ( - subgoal `?i. SOME x'' = oEL i x_list` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - IMP_RES_TAC FILTER_MEM >> - QSPECL_X_ASSUM ``!x. MEM x x_list' ==> MEM x ms_list`` [`x''`] >> - Q.SUBGOAL_THEN `MEM (HD x_list') x_list'` (fn thm => rfs [thm]) >- ( - rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ) >> - fs [listTheory.MEM_EL] >> - qexists_tac `n'` >> - fs [listTheory.oEL_THM] - ) >> - qexists_tac `i` >> - fs [listTheory.oEL_EQ_EL, FUNPOW_OPT_LIST_EQ_SOME] >> - (* Left to prove: Why can't x'' be the last element in x_list? *) +subgoal `?i. (OLEAST i. oEL i x_list = SOME x'') = SOME i /\ i < (PRE n)` >- ( + IMP_RES_TAC FILTER_OLEAST_HD >> + gs [] >> + fs [whileTheory.OLEAST_EQ_SOME] >> + Cases_on `i = PRE n` >- ( subgoal `P' x''` >- ( IMP_RES_TAC FILTER_MEM >> QSPECL_X_ASSUM ``!x. MEM x x_list' ==> P' x`` [`x''`] >> + PAT_ASSUM ``x'' = HD x_list'`` (fn thm => fs [thm]) >> Q.SUBGOAL_THEN `MEM (HD x_list') x_list'` (fn thm => rfs [thm]) >- ( rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] ) ) >> subgoal `LAST x_list = x'` >- ( - cheat + fs [INDEX_FIND_EQ_SOME_0] >> + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + subgoal `x_list <> []` >- ( + Cases_on `x_list` >> ( + fs [] + ) + ) >> + metis_tac [listTheory.LAST_EL] ) >> subgoal `x'' = x'` >- ( - fs [INDEX_FIND_EQ_SOME_0] + fs [listTheory.oEL_THM, INDEX_FIND_EQ_SOME_0] ) >> rw [] >> fs [] ) >> - fs [] + fs [FUNPOW_OPT_LIST_EQ_SOME, listTheory.oEL_THM] ) >> qexists_tac `SUC i` >> fs [] >> @@ -1102,7 +1111,23 @@ rpt strip_tac >| [ (* subgoal 3a. OK: SUC i steps taken until first encounter of l * EL i ms_list = HD ms_list' is among assumptions *) subgoal `?x_list''. FUNPOW_OPT_LIST f (SUC i) x = SOME (x::x_list'')` >- ( - cheat + subgoal `SUC i <= n` >- ( + fs [] + ) >> + IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> + fs [] >> + qexists_tac `TL l'` >> + subgoal `x = HD l'` >- ( + Cases_on `l'` >> ( + fs [FUNPOW_OPT_LIST_EQ_SOME] + ) + ) >> + subgoal `~NULL l'` >- ( + Cases_on `l'` >> ( + fs [FUNPOW_OPT_LIST_EQ_SOME] + ) + ) >> + metis_tac [listTheory.CONS] ) >> qexists_tac `x_list''` >> fs [] >> @@ -1110,13 +1135,25 @@ rpt strip_tac >| [ rpt strip_tac >| [ fs [FUNPOW_OPT_LIST_EQ_SOME], + fs [whileTheory.OLEAST_EQ_SOME] >> subgoal `EL i x_list'' = EL i x_list` >- ( - cheat + irule EL_PRE_CONS_EQ >> + qexists_tac `x` >> + irule FUNPOW_OPT_LIST_EL_EQ >> + qexists_tac `f` >> + qexists_tac `n` >> + qexists_tac `SUC i` >> + qexists_tac `x` >> + fs [] ) >> - fs [], + fs [listTheory.oEL_THM], - subgoal `MEM (HD x_list') (FILTER P' x_list')` >- ( - cheat + subgoal `MEM (HD x_list') (FILTER P' x_list)` >- ( + rw [] >> + irule MEM_HD >> + Cases_on `FILTER P' x_list` >> ( + fs [] + ) ) >> fs [listTheory.MEM_FILTER], @@ -1124,10 +1161,11 @@ rpt strip_tac >| [ (* P': by FILTER_BEFORE *) (* P: by INDEX_FIND 0 P x_list = SOME (PRE n,x') *) fs [] >| [ - subgoal `(LEAST i. EL i x_list = HD x_list') = i` >- ( - cheat - ) >> IMP_RES_TAC FILTER_BEFORE >> + QSPECL_X_ASSUM ``!i. (OLEAST i. oEL i x_list = SOME (HD x_list')) = SOME i ==> !i'. i' < i ==> ~P' (EL i' x_list)`` [`i`] >> + gs [] >> + QSPECL_X_ASSUM ``!i'. i' < i ==> ~P' (EL i' x_list)`` [`j'`] >> + rfs [] >> `EL j' x_list'' = EL j' x_list` suffices_by ( metis_tac [] ) >> @@ -1158,6 +1196,7 @@ rpt strip_tac >| [ ], (* subgoal 3b. OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> qexists_tac `DROP (SUC i) x_list` >> rpt strip_tac >| [ metis_tac [FUNPOW_OPT_LIST_SUFFIX], diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 1d0d2dc6b..5e3dd8167 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -75,8 +75,7 @@ EQ_TAC >> ( fs [weak_rel_steps_def], fs [weak_rel_steps_def] >> - IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS_nicer >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST m.trs n' ms = SOME (ms::SNOC ms' l)`` [`n`] >> + IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS_exact >> fs [] >> fs [INDEX_FIND_EQ_SOME_0, FUNPOW_OPT_LIST_EQ_SOME] >> rpt strip_tac >| [ @@ -872,110 +871,6 @@ rpt strip_tac >| [ * See FUNPOW_OPT_LIST_FILTER_FIRST *) PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> metis_tac [weak_rel_steps_list_states_subgoal_3_lemma], -(* OLD: - subgoal `?ms''. ms'' = EL 0 (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - metis_tac [] - ) >> - (* TODO: The below is used in multiple subgoals... *) - subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( - fs [] - ) >> - (* Note: last state in ms_list can't be at label l *) - subgoal `?i. ms'' = EL i ms_list /\ i < (PRE n)` >- ( - subgoal `?i. SOME ms'' = oEL i ms_list` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - IMP_RES_TAC FILTER_MEM >> - QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> MEM x ms_list`` [`ms''`] >> - Q.SUBGOAL_THEN `MEM (HD ms_list') ms_list'` (fn thm => rfs [thm]) >- ( - rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ) >> - fs [listTheory.MEM_EL] >> - qexists_tac `n'` >> - fs [listTheory.oEL_THM] - ) >> - qexists_tac `i` >> - fs [listTheory.oEL_EQ_EL, FUNPOW_OPT_LIST_EQ_SOME] >> - Cases_on `i = PRE n` >- ( - subgoal `m.pc ms'' = l` >- ( - IMP_RES_TAC FILTER_MEM >> - QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> (\ms. m.pc ms = l) x`` [`ms''`] >> - Q.SUBGOAL_THEN `MEM (HD ms_list') ms_list'` (fn thm => rfs [thm]) >- ( - rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ) - ) >> - fs [weak_rel_steps_def] >> - subgoal `ms'' = ms'` >- ( - `LAST (ms::ms_list) = EL (PRE n) ms_list` suffices_by ( - fs [] - ) >> - subgoal `LAST (ms::ms_list) = EL (PRE (LENGTH (ms::ms_list))) (ms::ms_list)` >- ( - irule listTheory.LAST_EL >> - fs [] - ) >> - subgoal `PRE (LENGTH (ms::ms_list)) = n` >- ( - SIMP_TAC list_ss [] >> - metis_tac [] - ) >> - fs [rich_listTheory.EL_CONS, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ) >> - fs [] - ) >> - fs [] - ) >> - qexists_tac `SUC i` >> - fs [] >> - rpt strip_tac >| [ - (* subgoal 3a. OK: SUC i steps taken until first encounter of l - * EL i ms_list = HD ms_list' is among assumptions *) - fs [weak_rel_steps_def] >> - rpt strip_tac >| [ - (* HD ms_list' reached in SUC i steps from ms *) - fs [FUNPOW_OPT_LIST_EQ_SOME], - - (* HD ms_list' is either l or in ls *) - IMP_RES_TAC FILTER_MEM >> - QSPECL_X_ASSUM ``!x. MEM x ms_list' ==> (\ms. m.pc ms = l) x`` [`HD ms_list'`] >> - Q.SUBGOAL_THEN `MEM (HD ms_list') ms_list'` (fn thm => rfs [thm]) >- ( - rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ), - - (* At n' < SUC i steps, we are neither at l nor in ls *) - QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls`` [`n'`] >> - rfs [] >> - ONCE_REWRITE_TAC [EQ_SYM_EQ] >> - `~(\ms. m.pc ms = l) ms'3'` suffices_by ( - fs [] - ) >> - irule FILTER_NOT_MEM >> - qexists_tac `ms_list` >> - qexists_tac `ms_list'` >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - (* OK: ms'3' is in ms_list (since n' < n) but not in ms_list' (since n' < SUC i, so before first encounter) *) - CONJ_TAC >| [ - IMP_RES_TAC FILTER_BEFORE >> - QSPECL_X_ASSUM ``!i'. i' < i ==> ~MEM (EL i' ms_list) ms_list'`` [`PRE n'`] >> - rfs [] >> - `EL (PRE n') ms_list = ms'3'` suffices_by ( - metis_tac [] - ) >> - metis_tac [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF], - - QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`n'`] >> - rfs [] >> - irule MEM_EL_CONS >> - fs [] - ] - ], - - (* subgoal 3b. OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) - irule weak_rel_steps_intermediate_start >> - fs [] >> - qexists_tac `ms` >> - fs [FUNPOW_OPT_LIST_EQ_SOME] - ], -*) (* subgoal 4. OK: Last element in filtered list can perform weak transition with ending * label set ({l} UNION ls) and reach ms' *) From 5ba63788eca8ecc235fbe5df720553ed50b7e0bb Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Wed, 11 May 2022 03:01:19 +0200 Subject: [PATCH 0098/1015] More fixes to cheats in abstract_hoare_logic_auxScript --- .../abstract_hoare_logic_auxScript.sml | 43 ++++++++++++++++++- 1 file changed, 41 insertions(+), 2 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index c4debf047..b32356ba3 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -844,15 +844,54 @@ Theorem FUNPOW_OPT_LIST_EXISTS_nicer: n' <= n ==> ?l. FUNPOW_OPT_LIST f n' x = SOME (x::l) Proof -cheat +rpt strip_tac >> +IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> +Cases_on `n'` >> Cases_on `l` >| [ + fs [FUNPOW_OPT_LIST_def], + + fs [FUNPOW_OPT_LIST_def], + + fs [FUNPOW_OPT_LIST_tail] >> + Cases_on `f x` >> ( + fs [] + ) >> + Cases_on `FUNPOW_OPT_LIST f n'' x''` >> ( + fs [] + ), + + qexists_tac `t` >> + fs [FUNPOW_OPT_LIST_tail] >> + Cases_on `f x` >> ( + fs [] + ) >> + Cases_on `FUNPOW_OPT_LIST f n'' x''` >> ( + fs [] + ) +] QED Theorem FUNPOW_OPT_LIST_EXISTS_exact: !f n x x'. FUNPOW_OPT f n x = SOME x' ==> + n > 0 ==> ?l. FUNPOW_OPT_LIST f n x = SOME (x::(SNOC x' l)) Proof -cheat +rpt strip_tac >> +IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS_nicer >> +QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST f n' x = SOME (x::l)`` [`n`] >> +fs [] >> +IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> +fs [listTheory.LAST_DEF] >> +Cases_on `l = []` >> ( + fs [] +) >| [ + (* TODO: Lemma *) + cheat, + + qexists_tac `FRONT l` >> + rw [] >> + metis_tac [listTheory.APPEND_FRONT_LAST] +] QED Theorem FUNPOW_OPT_LIST_EL: From 996ea515cab1a5084ed7c5a283d1e61521490731 Mon Sep 17 00:00:00 2001 From: Andreas Lindner Date: Wed, 11 May 2022 17:58:43 +0200 Subject: [PATCH 0099/1015] Add example code to produce a cfg visualization --- src/tools/cfg/examples/example-aes.sml | 37 ++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 src/tools/cfg/examples/example-aes.sml diff --git a/src/tools/cfg/examples/example-aes.sml b/src/tools/cfg/examples/example-aes.sml new file mode 100644 index 000000000..5f3aaeb5a --- /dev/null +++ b/src/tools/cfg/examples/example-aes.sml @@ -0,0 +1,37 @@ +open HolKernel Parse boolLib bossLib; + +val _ = Parse.current_backend := PPBackEnd.vt100_terminal; +val _ = wordsLib.add_word_cast_printer (); +val _ = Globals.show_types := true; + +(* prepare test program terms and theorems *) +val _ = load "../../lifter/examples/output/aesBinaryTheory"; +(*open toyBinaryTheory;*) +val lift_thm = aesBinaryTheory.aes_arm8_program_THM; +val prog_tm = ((snd o dest_comb o concl) lift_thm); + +(* build the dictionaries using the library under test *) +val _ = print "Building dictionaries.\n"; +open bir_block_collectionLib; +val bl_dict = gen_block_dict prog_tm; +val lbl_tms = get_block_dict_keys bl_dict; + +(* build the cfg and update the basic blocks *) +val _ = print "Building node dict.\n"; +open bir_cfgLib; +val n_dict = cfg_build_node_dict bl_dict lbl_tms; +val entries = [``BL_Address (Imm64 (0x400570w))``]; +val _ = print "Building cfg.\n"; +val g1 = cfg_create "aes" entries n_dict bl_dict; +(* +val _ = print "Updating cfg.\n"; +val n_dict = cfg_update_nodes_basic lbl_tms n_dict; +val g2 = cfg_update g1 n_dict; +*) + +(* display the cfg *) +val g_display = g1; +val _ = print "Display cfg.\n"; +open bir_cfg_vizLib; +val ns = List.map (valOf o (lookup_block_dict (#CFGG_node_dict g_display))) (#CFGG_nodes g_display); +val _ = cfg_display_graph_ns ns; From 81207050ba9b6a357a9f4a71543b80bfe8ece874 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 12 May 2022 09:29:05 +0200 Subject: [PATCH 0100/1015] Small updates to abstract_hoare_logic_auxScript --- .../abstract_hoare_logic_auxScript.sml | 251 +++++++++++++++++- 1 file changed, 241 insertions(+), 10 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index b32356ba3..1c7c36fad 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -118,13 +118,111 @@ fs [listTheory.MEM_FILTER] QED *) -Theorem FILTER_OLEAST_HD: +Theorem MEM_OLEAST: +!l x. +MEM x l ==> +?i. (OLEAST i. oEL i l = SOME x) = SOME i +Proof +Induct >> ( + fs [listTheory.MEM, listTheory.LENGTH] +) >> +rpt strip_tac >| [ + qexists_tac `0` >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM], + + qpat_assum `!x. _` (fn thm => imp_res_tac thm) >> + Cases_on `h = x` >- ( + qexists_tac `0` >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] + ) >> + qexists_tac `SUC i` >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> + rpt strip_tac >> + Cases_on `i'` >- ( + fs [] + ) >> + QSPECL_X_ASSUM ``!i'. _`` [`n`] >> + gs [] +] +QED + +(* TODO: Lemma stating no member of a filtered list has an index in the original list less than head of filtered list *) +Theorem FILTER_HD_OLEAST: + !P l l' x i i'. + FILTER P l = l' ==> + (OLEAST i. oEL i l = SOME (HD l')) = SOME i ==> + MEM x l' ==> + (OLEAST i. oEL i l = SOME x) = SOME i' ==> + i <= i' +Proof +cheat +(* +rpt strip_tac >> +CCONTR_TAC >> +subgoal `MEM (EL i' l) l'` >- ( + cheat +) >> +subgoal `HD l' <> x` >- ( + cheat +) >> +subgoal `0 < i'` >- ( + cheat +) >> +QSPECL_X_ASSUM ``!i''. i'' < i' ==> EL i'' l = x ==> ~(i'' < LENGTH l)`` [`0`] >> +gs [] >> +QSPECL_X_ASSUM ``!i''. i'' < i ==> EL i'' l <> HD l'`` [`0`] >> +gs [] >> +Cases_on `i = 0` >- ( + fs [] +) >> +gs [] >> +*) + + +(* +rpt strip_tac >> +fs [listTheory.MEM_EL] >> +qpat_x_assum `x = EL n l'` (fn thm => fs [thm]) >> +Cases_on `n` >- ( + cheat +) >> +fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> +Cases_on `i = 0` >- ( + fs [] +) >> +Cases_on `i' = 0` >- ( + fs [] >> + QSPECL_X_ASSUM ``!i''. i'' < i ==> EL i'' l = HD l' ==> ~(i'' < LENGTH l)`` [`i'`] >> + gs [] >> + cheat +) >> +Cases_on `i' < i` >- ( + fs [] >> + QSPECL_X_ASSUM ``!i''. i'' < i ==> EL i'' l = HD l' ==> ~(i'' < LENGTH l)`` [`i'`] >> + rfs [] >> + QSPECL_X_ASSUM ``!i''. i'' < i' ==> EL i'' l <> EL (SUC n') l'`` [`0`] >> + fs [] +) +*) +QED + +Theorem FILTER_HD_OLEAST_EXISTS: !P l l'. FILTER P l = l' ==> LENGTH l' > 0 ==> ?i. (OLEAST i. oEL i l = SOME (HD l')) = SOME i Proof -cheat +rpt strip_tac >> +subgoal `MEM (HD l') l'` >- ( + irule MEM_HD >> + fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] +) >> +subgoal `MEM (HD l') l` >- ( + metis_tac [listTheory.MEM_FILTER] +) >> +imp_res_tac MEM_OLEAST >> +qexists_tac `i` >> +fs [] QED (* Note: Since l can have duplicate elements, we need to make sure @@ -136,12 +234,61 @@ Theorem FILTER_BEFORE: (OLEAST i. oEL i l = SOME (HD l')) = SOME i ==> (!i'. i' < i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') Proof -cheat +rpt strip_tac >| [ + subgoal `MEM (EL i' l) l` >- ( + irule rich_listTheory.EL_MEM >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] + ) >> + subgoal `MEM (EL i' l) l'` >- ( + metis_tac [listTheory.MEM_FILTER] + ) >> + subgoal `?i''. (OLEAST i. oEL i l = SOME (EL i' l)) = SOME i''` >- ( + metis_tac [MEM_OLEAST] + ) >> + (* Contradictions after case analysis of i'' vs. i' and i *) + imp_res_tac FILTER_HD_OLEAST >> + Cases_on `i'' = i'` >- ( + fs [] + ) >> + Cases_on `i'' < i'` >- ( + fs [] + ) >> + Cases_on `i'' > i'` >- ( + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> + QSPECL_X_ASSUM ``!i'3'. i'3' < i'' ==> EL i'3' l = EL i' l ==> ~(i'3' < LENGTH l)`` [`i'`] >> + fs [arithmeticTheory.GREATER_DEF] + ) >> + fs [], + + (* Very similar to other case *) + subgoal `MEM (EL i' l) l` >- ( + irule rich_listTheory.EL_MEM >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] + ) >> + subgoal `?i''. (OLEAST i. oEL i l = SOME (EL i' l)) = SOME i''` >- ( + metis_tac [MEM_OLEAST] + ) >> + (* Contradictions after case analysis of i'' vs. i' and i *) + imp_res_tac FILTER_HD_OLEAST >> + Cases_on `i'' = i'` >- ( + fs [] + ) >> + Cases_on `i'' < i'` >- ( + fs [] + ) >> + Cases_on `i'' > i'` >- ( + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> + QSPECL_X_ASSUM ``!i'3'. i'3' < i'' ==> EL i'3' l = EL i' l ==> ~(i'3' < LENGTH l)`` [`i'`] >> + fs [arithmeticTheory.GREATER_DEF] + ) >> + fs [] +] QED (* TODO: Since l can have duplicate elements, we need to make sure * EL i l is the LAST encounter of LAST l' in l. *) (* TODO: Might require list nonempty or OLEAST... *) +(* TODO: Use bir_auxiliaryTheory.LAST_FILTER_EL *) Theorem FILTER_AFTER: !P l l' i. FILTER P l = l' ==> @@ -167,7 +314,30 @@ i < n ==> INDEX_FIND 0 P x_list = SOME (PRE n, x) ==> INDEX_FIND 0 P (DROP i x_list) = SOME (PRE (n - i), x) Proof -cheat +rpt strip_tac >> +fs [INDEX_FIND_EQ_SOME_0] >> +rpt strip_tac >| [ + subgoal `EL (PRE (n - i)) (DROP i x_list) = EL ((PRE (n - i)) + i) x_list` >- ( + irule listTheory.EL_DROP >> + fs [] + ) >> + fs [] >> + `i + PRE (n - i) = PRE n` suffices_by ( + rpt strip_tac >> + fs [] + ) >> + fs [], + + subgoal `j' + i < PRE n` >- ( + fs [arithmeticTheory.LESS_MONO_ADD_EQ] + ) >> + Q.SUBGOAL_THEN `EL j' (DROP i x_list) = EL (j' + i) x_list` (fn thm => fs [thm]) >- ( + irule listTheory.EL_DROP >> + fs [] + ) >> + QSPECL_X_ASSUM ``!j'. j' < PRE n ==> ~P (EL j' x_list)`` [`i + j'`] >> + fs [] +] QED Theorem EL_PRE_CONS_EQ: @@ -284,12 +454,26 @@ Definition FUNPOW_OPT_LIST_def: | NONE => NONE) End +Theorem FUNPOW_OPT_LIST_HD: + !f n s l. + FUNPOW_OPT_LIST f n s = SOME l ==> + ?l'. FUNPOW_OPT_LIST f n s = SOME (s::l') +Proof +cheat +QED + Theorem FUNPOW_OPT_LIST_SUC_NONE: !f n s l. FUNPOW_OPT_LIST f n s = SOME l ==> f (LAST l) = NONE ==> FUNPOW_OPT f (SUC n) s = NONE Proof +rpt strip_tac >> +fs [arithmeticTheory.ADD1] >> +ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> +irule FUNPOW_OPT_ADD_NONE >> +qexists_tac `LAST l` >> +fs [FUNPOW_OPT_compute] >> cheat QED @@ -320,8 +504,22 @@ Theorem FUNPOW_OPT_LIST_EQ_SOME: !i. (SUC i) < LENGTH l ==> f (EL i l) = SOME (EL (SUC i) l) Proof -cheat -(* TODO: Use FUNPOW_OPT_LIST_NEQ_NONE_PREV *) +rpt strip_tac >> +EQ_TAC >| [ + (* TODO: Lemmatize *) + rpt strip_tac >| [ + cheat, + + cheat, + + (* TODO: Use FUNPOW_OPT_LIST_NEQ_NONE_PREV *) + cheat, + + cheat + ], + + cheat +] QED Theorem FUNPOW_OPT_LIST_EQ_NONE: @@ -885,8 +1083,8 @@ fs [listTheory.LAST_DEF] >> Cases_on `l = []` >> ( fs [] ) >| [ - (* TODO: Lemma *) - cheat, + imp_res_tac FUNPOW_OPT_LIST_LENGTH >> + fs [], qexists_tac `FRONT l` >> rw [] >> @@ -988,12 +1186,42 @@ Cases_on `FUNPOW_OPT_LIST f n' x'` >> ( ) QED +(* TODO: Rename to FUNPOW_OPT_LIST_DROP? *) Theorem FUNPOW_OPT_LIST_SUFFIX: !f n i x x_list. +SUC i <= n ==> FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> FUNPOW_OPT_LIST f (n - SUC i) (EL i x_list) = SOME (EL i x_list::DROP (SUC i) x_list) Proof -cheat +rpt strip_tac >> +imp_res_tac FUNPOW_OPT_LIST_APPEND >> +subgoal `EL i x_list = LAST l'` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] >> + gs [] +) >> +fs [FUNPOW_OPT_LIST_tail] >> +Cases_on `f x` >> ( + fs [] +) >> +Cases_on `FUNPOW_OPT_LIST f i x'` >> ( + fs [] +) >> +qpat_x_assum `x::x'' = l'` (fn thm => fs [GSYM thm]) >> +qpat_x_assum `x'' ++ DROP 1 l'' = x_list` (fn thm => fs [GSYM thm]) >> +subgoal `LENGTH x'' = SUC i` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] +) >> +Q.SUBGOAL_THEN `DROP (SUC i) (x'' ++ DROP 1 l'') = (DROP (SUC i) x'') ++ DROP 1 l''` + (fn thm => fs [thm]) >- ( + irule rich_listTheory.DROP_APPEND1 >> + fs [] +) >> +fs [listTheory.DROP_LENGTH_TOO_LONG] >> +Cases_on `l''` >- ( + fs [FUNPOW_OPT_LIST_EQ_SOME] +) >> +imp_res_tac FUNPOW_OPT_LIST_HD >> +gs [] QED (* @@ -1113,7 +1341,7 @@ subgoal `LENGTH x_list > 0` >- ( fs [INDEX_FIND_EQ_SOME_0] ) >> subgoal `?i. (OLEAST i. oEL i x_list = SOME x'') = SOME i /\ i < (PRE n)` >- ( - IMP_RES_TAC FILTER_OLEAST_HD >> + IMP_RES_TAC FILTER_HD_OLEAST_EXISTS >> gs [] >> fs [whileTheory.OLEAST_EQ_SOME] >> @@ -1238,6 +1466,9 @@ rpt strip_tac >| [ fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> qexists_tac `DROP (SUC i) x_list` >> rpt strip_tac >| [ + subgoal `SUC i <= n` >- ( + fs [] + ) >> metis_tac [FUNPOW_OPT_LIST_SUFFIX], irule INDEX_FIND_SUFFIX >> From cb1167725fda11c6bf90e4612f6616a2b10dc8bc Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 16 May 2022 09:57:10 +0200 Subject: [PATCH 0101/1015] New proof approach for partial correctness loop rule re-using total correctness rule --- .../abstract_hoare_logicScript.sml | 4 +- .../abstract_hoare_logic_auxScript.sml | 12 + .../abstract_hoare_logic_partialScript.sml | 837 ++++++++---------- 3 files changed, 405 insertions(+), 448 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index f2dcd3303..4933fe419 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -38,8 +38,8 @@ val weak_model_def = Define ` )`; -val weak_comp_thm = prove(`` - !m. +val weak_comp_thm = store_thm("weak_comp_thm", +``!m. weak_model m ==> !ms ls1 ls2 ms' ms''. (m.weak ms (ls1 UNION ls2) ms') ==> (~((m.pc ms') IN ls2)) ==> diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index 1c7c36fad..8362925ce 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -288,6 +288,7 @@ QED (* TODO: Since l can have duplicate elements, we need to make sure * EL i l is the LAST encounter of LAST l' in l. *) (* TODO: Might require list nonempty or OLEAST... *) +(* TODO: Use EXISTENTIAL quantification for i *) (* TODO: Use bir_auxiliaryTheory.LAST_FILTER_EL *) Theorem FILTER_AFTER: !P l l' i. @@ -299,6 +300,9 @@ cheat QED (* TODO: This is just plain wrong... *) +(* TODO: Would it suffice with + * "there exists i', i'' such that i' < i'', EL i' l = EL i (FILTER P l) and + * EL i'' l = EL (SUC i) (FILTER P l)"? *) Theorem FILTER_ORDER: !P l i i' i''. EL i' l = EL i (FILTER P l) ==> @@ -307,6 +311,14 @@ Theorem FILTER_ORDER: Proof cheat QED +Theorem FILTER_ORDER_alt: + !P l i x x'. + SOME x = oEL i (FILTER P l) ==> + SOME x' = oEL (SUC i) (FILTER P l) ==> + (?i' i''. i' < i'' /\ x = EL i' l /\ x' = EL i'' l /\ (!i'''. i''' > i' /\ i''' < i'' ==> ~P (EL i''' l))) +Proof +cheat +QED Theorem INDEX_FIND_SUFFIX: !P n i x_list x. diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 5e3dd8167..3cc458444 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -630,6 +630,69 @@ rpt strip_tac >> metis_tac [weak_unique_thm] QED +(* Note: exactly abstract_jgmt_imp_partial_triple *) +Theorem total_to_partial: + !m l ls pre post. + weak_model m ==> + abstract_jgmt m l ls pre post ==> + abstract_partial_jgmt m l ls pre post +Proof +fs [abstract_jgmt_imp_partial_triple] +QED + +(* Discussion version: + !m l ls pre post. + weak_model m ==> + (!ms. m.pc ms = l /\ pre ms ==> (?ms'. m.weak ms ls ms') ==> + abstract_partial_jgmt m l ls pre post ==> + abstract_jgmt m l ls pre post) +*) +Theorem partial_to_total: + !m l ls pre post. + weak_model m ==> + (!ms. m.pc ms = l /\ pre ms ==> ?ms'. m.weak ms ls ms') ==> + abstract_partial_jgmt m l ls pre post ==> + abstract_jgmt m l ls pre post +Proof +cheat +QED + +(* !!!!!!!!!!!!!!!!!!!!! *) +(* Suggested lemma to factor out from total correctness version of seq rule: *) +Theorem seq_lemma: +!m ls1 ls2 post. +weak_model m ==> +!ms. +?ms'. m.weak ms (ls1 UNION ls2) ms' /\ post ms' /\ +(m.pc ms' NOTIN ls2 ==> ?ms''. m.weak ms' ls2 ms'' /\ post ms'') ==> +?ms'''. m.weak ms ls2 ms''' /\ post ms''' +Proof +cheat +QED + +(* Suggested lemmata to use: + + m.weak ms ls ms' ==> ?ms''. m.weak ms (ls1 UNION ls2) ms'' + + (* Same as seq_lemma? *) + ?ms''. m.weak ms ls' ms'' /\ (!ms'''. m.weak ms ls' ms''' => post ms''') ==> ?ms''''. m.weak ms ls' ms'''' /\ post ms'''' + +*) + +(* If we know that ms terminates, then we maybe could prove the premises of the + * total-correctnesss seq rule in the following format: + + [pre a /\ a = ms]l->(ls1 U ls2)[post a] + !l1 in ls1. [post a /\ weak ms ls1 a /\ a in l1]l1->ls2[post a] + + * No, second premise must have identical pre-and postcondition... + *) + +(* Another lemma suggestion: identical to intermediate label lemma? + + m.weak ms ls ms' /\ m.weak ms ls U ls' ms'' /\ ms''<>ms' [ms'' not in ls'] ==> + m.weak ms'' ls ms' +*) Theorem weak_partial_seq_rule_thm: !m l ls1 ls2 pre post. @@ -639,6 +702,125 @@ Theorem weak_partial_seq_rule_thm: (abstract_partial_jgmt m l1 ls2 post post)) ==> abstract_partial_jgmt m l ls2 pre post Proof +(* Trying to use seq_lemma: +rpt strip_tac >> +FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +rpt strip_tac >> +imp_res_tac seq_lemma >> +QSPECL_X_ASSUM ``!post ms ls2 ls1. _`` [`post`, `ms`, `ls2`, `ls1`] >> +fs [] >> +subgoal `?ms'. m.weak ms (ls1 UNION ls2) ms'` >- ( + cheat +) >> +subgoal `post ms'3'` >- ( + cheat +) >> +Cases_on `m.pc ms'3' IN ls2` >- ( + cheat +) >> +(* TODO: Probably does not work *) +*) + +rpt strip_tac >> +SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +rpt strip_tac >> +subgoal `?ms'. m.weak ms (ls1 UNION ls2) ms'` >- ( + (* There is at least ms', possibly another state if ls1 is encountered before *) + cheat +) >> +Cases_on `m.pc ms'' IN ls2` >- ( + (* If ls2 was reached without encountering ls1, we win immediately *) + cheat +) >> +subgoal `m.pc ms'' IN ls1` >- ( + (* Set theory *) + cheat +) >> +subgoal `?l1. m.pc ms'' = l1` >- ( + (* Technically requires ls1 non-empty, but if that is the case, we also win immediately *) + cheat +) >> +subgoal `abstract_jgmt m l (ls1 UNION ls2) (\s. s = ms /\ pre s) (\s. (m.pc s IN ls1 ==> s = ms'') /\ (m.pc s IN ls2 ==> post s))` >- ( + fs [abstract_jgmt_def, abstract_partial_jgmt_def] >> + qexists_tac ‘ms''’ >> + fs [] +) >> +subgoal `!l1'. (l1' IN ls1) ==> (abstract_jgmt m l1' ls2 (\s. (m.pc s IN ls1 ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)) (\s. (m.pc s IN ls1 ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)))` >- ( + rpt strip_tac >> + fs [abstract_jgmt_def, abstract_partial_jgmt_def] >> + rpt strip_tac >> + res_tac >> + subgoal `s' = ms''` >- ( + (* Both reached by m.weak ms (ls1 UNION ls2) *) + metis_tac [weak_unique_thm] + ) >> + fs [] >> + subgoal `m.weak ms'' ls2 ms'` >- ( + (* Since ms'' is a ls1-point encountered between ms and ls2 *) + cheat + ) >> + qexists_tac ‘ms'’ >> + fs [] >> + (* OK: ms'3' is not in ls1 (weak_pc_in_thm) *) + cheat +) >> +imp_res_tac abstract_seq_rule_thm >> +gs [abstract_jgmt_def] >> +subgoal `s' = ms'` >- ( + (* Both reached by m.weak ms ls2 *) + metis_tac [weak_unique_thm] +) >> +subgoal `m.pc ms' IN ls2` >- ( + (* Reached by m.weak ms ls2 *) + metis_tac [weak_pc_in_thm] +) >> +metis_tac [] + +(* Straight-up reuse of total-correctness rule: *) +(* +rpt strip_tac >> +(* Experiment with trying to case split on termination: +Cases_on ‘(!ms. m.pc ms = l /\ pre ms ==> ~(?ms'. m.weak ms ls2 ms'))’ >- ( + fs [abstract_partial_jgmt_def] +) >> +*) +(* Experiment with trying to case split on termination: +subgoal ‘(!ms. m.pc ms = l /\ pre ms ==> (?ms'. m.weak ms ls2 ms'))’ >- ( + cheat +) >> +*) +fs [] >> +irule total_to_partial >> +fs [] >> +irule abstract_seq_rule_thm >> +fs [] >> +qexists_tac ‘ls1’ >> +conj_tac >| [ + rpt strip_tac >> + irule partial_to_total >> + fs [] >> + rpt strip_tac >> + QSPECL_X_ASSUM ``!l1. l1 IN ls1 ==> _`` [`l1`] >> + rfs [abstract_partial_jgmt_def] >> + res_tac >> + (* What to do here: Existence of ms' such that m.weak ms ls2 ms' unclear *) + QSPECL_X_ASSUM `` !ms. m.pc ms = l /\ pre ms ==> ?ms'. m.weak ms ls2 ms'`` [`ms`] >> + fs [] >> + metis_tac [] + cheat, + + irule partial_to_total >> + fs [] >> + rpt strip_tac >> + fs [abstract_partial_jgmt_def] >> + res_tac >> + (* What to do here: Same problem as above *) + cheat +] +*) + +(* OLD, working proof: *) +(* rpt strip_tac >> FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> rpt strip_tac >> @@ -665,377 +847,129 @@ subgoal `post ms''` >- ( metis_tac [pred_setTheory.UNION_COMM] ) >> metis_tac [pred_setTheory.UNION_COMM, weak_intermediate_labels2] +*) QED +Definition weak_partial_loop_contract_def: + weak_partial_loop_contract m l le invariant C1 = + (l NOTIN le /\ + abstract_partial_jgmt m l ({l} UNION le) (\ms. invariant ms /\ C1 ms) + (\ms. m.pc ms = l /\ invariant ms)) +End + +(* Applies trs a maximum of n_max times until state s has been + * reached, counting the number of times ls has been encountered + * in the process *) +Definition trs_to_s_count_ls_def: + (trs_to_s_count_ls mod ms ls s 0 n_ls = SOME n_ls) /\ + (trs_to_s_count_ls mod ms ls s (SUC n) n_ls = + if ms = s + then SOME n_ls + else + (case mod.trs ms of + NONE => NONE + | SOME ms' => + if mod.pc ms' IN ls + then trs_to_s_count_ls mod ms' ls s n (SUC n_ls) + else trs_to_s_count_ls mod ms' ls s n n_ls)) +End -Theorem weak_rel_steps_list_states_subgoal_2_lemma: -!m n ms ms' ms_list ls l. +(* TODO: Overkill? *) +Definition oadd_def: + (oadd NONE _ = NONE) /\ + (oadd _ NONE = NONE) /\ + (oadd (SOME (n:num)) (SOME n') = SOME (n + n')) +End + +Theorem weak_superset_thm: + !m. weak_model m ==> - n > 0 ==> - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> - l NOTIN ls ==> - FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = [] ==> - INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list = - SOME (PRE n,ms') + !ms ms' ls1 ls2. + m.weak ms ls1 ms' ==> + ?ms''. m.weak ms (ls1 UNION ls2) ms'' Proof -rpt strip_tac >> -Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) = (\ms''. (\ms'''. m.pc ms''' IN ls) ms'' \/ (\ms'''. m.pc ms''' IN {l}) ms'')` (fn thm => REWRITE_TAC [thm]) >- ( - fs [] >> - metis_tac [] -) >> -irule FUNPOW_OPT_LIST_FILTER_NULL >> -fs [] >> -metis_tac [] +cheat QED -Theorem weak_rel_steps_list_states_subgoal_3_lemma: -!m n ms ms' ms_list ls l. +Theorem loop_lemma_1: + !m. weak_model m ==> - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> - l NOTIN ls ==> - FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> - LENGTH (FILTER (\ms. m.pc ms = l) ms_list) > 0 ==> - ?n'. - (n' > 0 /\ - ?ms_list'. - FUNPOW_OPT_LIST m.trs n' ms = SOME (ms::ms_list') /\ - INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list' = - SOME (PRE n',HD (FILTER (\ms. m.pc ms = l) ms_list))) /\ - (n > n' /\ - ?ms_list'. - FUNPOW_OPT_LIST m.trs (n - n') - (HD (FILTER (\ms. m.pc ms = l) ms_list)) = - SOME (HD (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list' = - SOME (PRE (n - n'),ms')) /\ n' < n /\ n' > 0 + !ms s ms' l le n n_l. + m.weak ms le ms' ==> + s <> ms' ==> + trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l ==> + ?s'. m.weak s ({l} UNION le) s' Proof -rpt strip_tac >> -Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) = (\ms''. (\ms'''. m.pc ms''' IN {l}) ms'' \/ (\ms'''. m.pc ms''' IN ls) ms'')` (fn thm => REWRITE_TAC [thm]) >- ( - fs [] >> - metis_tac [] -) >> -Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l) = (\ms'3'. m.pc ms'3' IN {l})` (fn thm => REWRITE_TAC [thm]) >- ( - fs [] >> - metis_tac [] -) >> -irule FUNPOW_OPT_LIST_FILTER_FIRST >> -fs [] >> -subgoal `ms' = LAST ms_list` >- ( - fs [INDEX_FIND_EQ_SOME_0] >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - rw [] >> - ONCE_REWRITE_TAC [EQ_SYM_EQ] >> - irule listTheory.LAST_EL >> - (* TODO: Find nice lemma for this... *) - Cases_on `ms_list` >> ( - fs [] - ) -) >> -fs [INDEX_FIND_EQ_SOME_0] >> -metis_tac [IN_NOT_IN_NEQ_thm] +cheat QED -Theorem weak_rel_steps_list_states_subgoal_4_lemma: -!m n ms ms' ms_list ls l. +(* TODO: Add all necessary antecedents... *) +Theorem loop_lemma_2: + !m. weak_model m ==> - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> - l NOTIN ls ==> - FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> - LENGTH (FILTER (\ms. m.pc ms = l) ms_list) > 0 ==> - ?n''. - (?ms_list'. - FUNPOW_OPT_LIST m.trs n'' - (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) - (FILTER (\ms. m.pc ms = l) ms_list)) = - SOME - (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) - (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ - INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list' = - SOME (PRE n'',ms')) /\ n'' > 0 + !ms s ms''' l le n n_l. + l NOTIN le ==> + trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l ==> + m.weak s ({l} UNION le) ms'3' ==> + m.pc ms'3' = l ==> + trs_to_s_count_ls m ms ({l} UNION le) ms'3' n 0 = SOME (SUC n_l) Proof -rpt strip_tac >> -subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( - fs [] -) >> -Q.SUBGOAL_THEN `EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) - (FILTER (\ms. m.pc ms = l) ms_list) = LAST ms_list'` (fn thm => REWRITE_TAC [thm]) >- ( - (* By listTheory.LAST_EL *) - fs [] >> - ONCE_REWRITE_TAC [EQ_SYM_EQ] >> - ONCE_REWRITE_TAC [GSYM arithmeticTheory.PRE_SUB1] >> - irule listTheory.LAST_EL >> - fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] -) >> -Q.SUBGOAL_THEN `(\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) = (\ms''. (\ms'''. m.pc ms''' IN {l}) ms'' \/ (\ms'''. m.pc ms''' IN ls) ms'')` (fn thm => REWRITE_TAC [thm]) >- ( - fs [] >> - metis_tac [] -) >> -irule FUNPOW_OPT_LIST_FILTER_LAST >> -fs [] >> -qexists_tac `n` >> -qexists_tac `ms` >> -qexists_tac `ms_list` >> -fs [] +cheat QED - -Theorem weak_rel_steps_list_states_subgoal_5_lemma: -!m n ms ms' ms_list ls l i. +Theorem loop_lemma_3: + !m. + weak_model m ==> + !ms s ms''' ms' l le n n_l. + l NOTIN le ==> + m.weak ms le ms' ==> + trs_to_s_count_ls m s ({l} UNION le) ms' n 0 = SOME n_l ==> + m.weak s ({l} UNION le) ms'3' ==> + m.pc ms'3' = l ==> + trs_to_s_count_ls m ms''' ({l} UNION le) ms' n 0 = SOME (PRE n_l) +Proof +cheat +QED +(* TODO: Needs to take into account number of transitions used *) +Theorem loop_lemma_4: + !m. + weak_model m ==> + !ms s' ms' l le n n_l. + l NOTIN le ==> + m.weak ms le ms' ==> + trs_to_s_count_ls m ms ({l} UNION le) s' n 0 = SOME n_l ==> + m.weak s' le ms' +Proof +cheat +QED +Theorem loop_lemma_5: + !m. weak_model m ==> - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n,ms') ==> - l NOTIN ls ==> - FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> - i < LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1 ==> - ?n' n''. - (?ms_list'. - FUNPOW_OPT_LIST m.trs n' - (EL i (FILTER (\ms. m.pc ms = l) ms_list)) = - SOME (EL i (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ - INDEX_FIND 0 (\ms''. m.pc ms'' = l \/ m.pc ms'' IN ls) ms_list' = - SOME (PRE n',EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list))) /\ - (?ms_list'. - FUNPOW_OPT_LIST m.trs n'' - (EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list)) = - SOME (EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list)::ms_list') /\ - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list' = SOME (PRE n'',ms')) /\ - n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0 + !ms ls n. + trs_to_s_count_ls m ms ls ms n 0 = SOME 0 Proof -metis_tac [FUNPOW_OPT_LIST_FILTER_BETWEEN] +cheat QED -(* This describes the necessary characteristics of the list ms_list, which consists of - * all states where l is encountered between ms and ms'. *) -Theorem weak_rel_steps_list_states: -!m ms l ls ms' n. +Theorem loop_lemma_6: + !m. weak_model m ==> + !ms ls l ms' n. weak_rel_steps m ms ls ms' n ==> - l NOTIN ls ==> - ?ms_list. - (!i. i < LENGTH ms_list ==> m.pc (EL i ms_list) = l) /\ - (LENGTH ms_list = 0 ==> weak_rel_steps m ms ({l} UNION ls) ms' n) /\ - (LENGTH ms_list > 0 ==> - (?n'. weak_rel_steps m ms ({l} UNION ls) (HD ms_list) n' /\ - weak_rel_steps m (HD ms_list) ls ms' (n - n') /\ n' < n /\ n' > 0) /\ - (?n''. weak_rel_steps m (EL ((LENGTH ms_list) - 1) ms_list) ({l} UNION ls) ms' n'' /\ n'' > 0) /\ - !i. (i < ((LENGTH ms_list) - 1) ==> ?n' n''. - weak_rel_steps m (EL i ms_list) ({l} UNION ls) (EL (i+1) ms_list) n' /\ - weak_rel_steps m (EL (i+1) ms_list) ls ms' n'' /\ n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0)) + ?n_l. trs_to_s_count_ls m ms ({l} UNION ls) ms' n 0 = SOME n_l Proof -rpt strip_tac >> -subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( - fs [weak_rel_steps_def] >> - IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST m.trs n' ms = SOME l`` [`n`] >> - fs [] >> - Cases_on `n` >- ( - fs [FUNPOW_OPT_LIST_def] - ) >> - subgoal `?ms''. m.trs ms = SOME ms''` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT m.trs n'' ms = SOME (EL n'' l')`` [`1`] >> - fs [FUNPOW_OPT_compute] >> - Cases_on `m.trs ms` >> ( - fs [] - ) - ) >> - subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n' ms'' = SOME ms_list` >- ( - metis_tac [FUNPOW_OPT_LIST_BACK_PRE] - ) >> - qexists_tac `ms_list` >> - (* TODO: Should be OK... - * (see also first subgoal in weak_rel_steps_smallest_exists, reuse this?) *) - IMP_RES_TAC FUNPOW_OPT_LIST_BACK_INCR >> - fs [] -) >> -qexists_tac `FILTER (\ms. m.pc ms = l) ms_list` >> -rpt strip_tac >| [ - (* subgoal 1. OK: by FILTER_MEM *) - subgoal `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list))` >- ( - (* TODO: Silly, but it works... *) - `(\ms. m.pc ms = l) (EL i (FILTER (\ms. m.pc ms = l) ms_list)) /\ MEM (EL i (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` suffices_by ( - fs [] - ) >> - irule FILTER_MEM >> - qexists_tac `FILTER (\ms. m.pc ms = l) ms_list` >> - metis_tac [listTheory.MEM_EL] - ) >> - fs [], - - (* subgoal 2. OK: If filtered list is empty, l can be inserted in ending label set - * See FUNPOW_OPT_LIST_FILTER_NULL *) - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> - metis_tac [weak_rel_steps_list_states_subgoal_2_lemma], - - (* subgoal 3. OK: First encounter of l is reached when filtered list is non-empty, - * also weak transition can proceed from there directly to ending label set - * See FUNPOW_OPT_LIST_FILTER_FIRST *) - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> - metis_tac [weak_rel_steps_list_states_subgoal_3_lemma], - - (* subgoal 4. OK: Last element in filtered list can perform weak transition with ending - * label set ({l} UNION ls) and reach ms' *) - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> - metis_tac [weak_rel_steps_list_states_subgoal_4_lemma], -(* OLD: - subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( - fs [] - ) >> - subgoal `MEM (EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list)) ms_list` >- ( - subgoal `MEM (EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - fs [listTheory.MEM_EL] >> - qexists_tac `PRE (LENGTH ms_list')` >> - fs [] - ) >> - metis_tac [FILTER_MEM] - ) >> - (* Note : this introduces n'3', the number of transitions to last encounter of l. *) - subgoal `?n'''. FUNPOW_OPT m.trs n''' ms = SOME (EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) (FILTER (\ms. m.pc ms = l) ms_list)) /\ n''' < n /\ n''' > 0` >- ( - fs [listTheory.MEM_EL] >> - qexists_tac `SUC n'` >> - rpt CONJ_TAC >| [ - fs [FUNPOW_OPT_LIST_EQ_SOME, arithmeticTheory.PRE_SUB1] >> - rw [], - - (* TODO: Last element of ms_list' not being in l contradiction *) - metis_tac [weak_rel_steps_FILTER_NOTIN_end], - - fs [] - ] - ) >> - IMP_RES_TAC weak_rel_steps_intermediate_start >> - qexists_tac `n - n'3'` >> - fs [] >> - ONCE_REWRITE_TAC [pred_setTheory.UNION_COMM] >> - irule weak_rel_steps_superset_after >> - rpt strip_tac >> ( - fs [] - ) >| [ - (* Find appropriate index in ms_list and use it, also lemma that indices after FILTER LAST do - * not have label l *) - qexists_tac `EL (PRE (n' + n'3')) ms_list` >> - CONJ_TAC >| [ - (* TODO: Lemma for this situation *) - irule FUNPOW_OPT_split >> - qexists_tac `n'3'` >> - qexists_tac `ms` >> - fs [] >> - metis_tac [FUNPOW_OPT_todoname], - -(* - subgoal `n'3' < n` >- ( - fs [] - ) >> -*) - subgoal `EL (PRE n'3') ms_list = LAST ms_list'` >- ( - subgoal `FUNPOW_OPT m.trs n'3' ms = SOME (EL (PRE n'3') ms_list)` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`n'3'`] >> - rfs [rich_listTheory.EL_CONS] - ) >> - subgoal `EL (PRE n'3') ms_list = EL (LENGTH (FILTER (\ms. m.pc ms = l) ms_list) - 1) - (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - fs [] - ) >> - fs [] >> - ONCE_REWRITE_TAC [EQ_SYM_EQ] >> - ONCE_REWRITE_TAC [GSYM arithmeticTheory.PRE_SUB1] >> - irule listTheory.LAST_EL >> - fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ) >> - IMP_RES_TAC FILTER_AFTER >> - QSPECL_X_ASSUM ``!i'. i' > PRE n'3' ==> ~(\ms. m.pc ms = l) (EL i' ms_list)`` [`(PRE (n' + n'3'))`] >> - `PRE (n' + n'3') > PRE n'3'` suffices_by ( - fs [] - ) >> - Cases_on `n'` >- ( - fs [] - ) >> - Cases_on `n'3'` >> ( - fs [] - ) - ], - - metis_tac [] - ], -*) - - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_to_FUNPOW_OPT_LIST thm]) >> - metis_tac [weak_rel_steps_list_states_subgoal_5_lemma] - (* subgoal 5. Inductive case for weak transition with ending label set ({l} UNION ls) - * between elements of the list (where the latter point goes to ms' with ending label set ls). - * Should also be OK *) - -(* OLD - subgoal `?ms_list'. FILTER (\ms. m.pc ms = l) ms_list = ms_list'` >- ( - fs [] - ) >> - subgoal `?i'. EL i' ms_list = EL i (FILTER (\ms. m.pc ms = l) ms_list) /\ i' < LENGTH ms_list` >- ( - subgoal `MEM (EL i (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - fs [rich_listTheory.EL_MEM] - ) >> - fs [listTheory.MEM_FILTER, listTheory.MEM_EL] >> - qexists_tac `n'` >> - rw [] - ) >> - subgoal `?i'. EL i' ms_list = EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list) /\ i' < LENGTH ms_list` >- ( - subgoal `MEM (EL (i + 1) (FILTER (\ms. m.pc ms = l) ms_list)) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - fs [rich_listTheory.EL_MEM] - ) >> - fs [listTheory.MEM_FILTER, listTheory.MEM_EL] >> - qexists_tac `n'` >> - rw [] - ) >> - subgoal `i' < i''` >- ( - irule FILTER_ORDER >> - qexists_tac `(\ms. m.pc ms = l)` >> - qexists_tac `i` >> - qexists_tac `ms_list` >> - fs [arithmeticTheory.ADD1] - ) >> - subgoal `n = LENGTH ms_list` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] - ) >> - qexists_tac `SUC i'' - SUC i'` >> - qexists_tac `n - (SUC i'')` >> - fs [] >> - rpt strip_tac >| [ - (* Weak transtion to ({l} UNION ls) between element i and element i+1 in ms_list' *) - metis_tac [weak_rel_steps_FILTER_inter], - - (* Weak transtion to ls between element i+1 and LAST of ms_list' *) - metis_tac [weak_rel_steps_FILTER_end], - - (* Phrased differently: "Why can't a member of ms_list' be the last element in ms_list?" *) - (* TODO: Last element of ms_list' not being in l contradiction *) - Cases_on `SUC i'' = LENGTH ms_list` >- ( - fs [weak_rel_steps_def] >> - subgoal `m.pc (EL i'' ms_list) = l` >- ( - subgoal `MEM (EL i'' ms_list) (FILTER (\ms. m.pc ms = l) ms_list)` >- ( - fs [listTheory.MEM_EL] >> - qexists_tac `i + 1` >> - fs [] - ) >> - fs [listTheory.MEM_FILTER] - ) >> - - subgoal `ms' = EL i'' ms_list` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME, listTheory.LAST_EL] >> - metis_tac [listTheory.EL_restricted] - ) >> - metis_tac [] - ) >> - fs [] - ] -*) -] +cheat QED -Definition weak_partial_loop_contract_def: - weak_partial_loop_contract m l le invariant C1 = - (l NOTIN le /\ - abstract_partial_jgmt m l ({l} UNION le) (\ms. invariant ms /\ C1 ms) - (\ms. m.pc ms = l /\ invariant ms)) -End +Theorem loop_lemma_7: + !m. + weak_model m ==> + !ms ls ms' n n_l. + trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> + m.pc ms' IN ls ==> + n_l > 0 +Proof +cheat +QED Theorem weak_partial_loop_rule_thm: !m. @@ -1046,118 +980,129 @@ Theorem weak_partial_loop_rule_thm: abstract_partial_jgmt m l le invariant post Proof rpt strip_tac >> -fs [abstract_partial_jgmt_def, weak_partial_loop_contract_def] >> +SIMP_TAC std_ss [abstract_partial_jgmt_def] >> rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> -IMP_RES_TAC weak_rel_steps_list_states >> -(* QSPECL_X_ASSUM ``!l. ?ms_list. _`` [`l`] >> *) -fs [] >> -Cases_on `ms_list = []` >- ( - fs [] >> - QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> - QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> - rfs [] >> - Cases_on `C1 ms` >| [ - metis_tac [weak_pc_in_thm, weak_rel_steps_imp], - +fs [weak_partial_loop_contract_def] >> +subgoal `?ms''. m.weak ms ({l} UNION le) ms''` >- ( + (* There is at least ms', possibly another state if l is encountered before *) + metis_tac [weak_superset_thm, pred_setTheory.UNION_COMM] +) >> +Cases_on `m.pc ms'' IN le` >- ( + (* If le was reached without encountering l, we win immediately *) + fs [abstract_partial_jgmt_def] >> + res_tac >> + Cases_on `~C1 ms` >> ( metis_tac [] - ] + ) ) >> -subgoal `LENGTH ms_list > 0` >- ( - fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] +subgoal `m.pc ms'' = l` >- ( + imp_res_tac weak_pc_in_thm >> + gs [pred_setTheory.IN_UNION] ) >> -fs [] >> -Cases_on `~C1 ms` >- ( - metis_tac [] +(* Needed to establish n *) +subgoal `?n. weak_rel_steps m ms le ms' n /\ n > 0` >- ( + (* Since m.weak to le connects ms and ms' by some non-zero number of transitions *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> + qexists_tac `n` >> + fs [weak_rel_steps_def] ) >> -fs [] >> -subgoal `m.pc ms' <> l` >- ( - metis_tac [weak_pc_in_thm, weak_rel_steps_imp] +(* Needed to establish n_l *) +subgoal `?n_l. trs_to_s_count_ls m ms ({l} UNION le) ms' n 0 = SOME n_l` >- ( + metis_tac [loop_lemma_6] ) >> -subgoal `!i. i < LENGTH ms_list ==> - (invariant (EL i ms_list) \/ post ms') /\ - (C1 (EL i ms_list) \/ (~C1 (EL i ms_list) /\ post ms'))` >- ( - Induct_on `i` >- ( - fs [] >> - QSPECL_X_ASSUM ``!i. _`` [`0`] >> - subgoal `invariant (EL 0 ms_list)` >- ( - fs [] >> - metis_tac [weak_rel_steps_intermediate_labels3, pred_setTheory.IN_SING] - ) >> - fs [] >> - Cases_on `C1 (HD ms_list)` >> ( - fs [] - ) >> - PAT_X_ASSUM ``!ms ms'. _`` (fn thm => irule thm) >> - qexists_tac `HD ms_list` >> - fs [] >> +(* Invariant: number of l-encounters from ms to current + number of l-encounters from current to ms' + * equals n_l. + * Variant: number of encounters of l until ms' is reached *) +subgoal `abstract_loop_jgmt m l le (\s. oadd (trs_to_s_count_ls m ms ({l} UNION le) s n 0) + (trs_to_s_count_ls m s ({l} UNION le) ms' n 0) = SOME n_l /\ invariant s) C1 (\s. THE (trs_to_s_count_ls m s ({l} UNION le) ms' n 0))` >- ( + fs [abstract_loop_jgmt_def, abstract_jgmt_def] >> + rpt strip_tac >> + subgoal `s <> ms'` >- ( + (* Since pc of s is l, m.weak ms le ms' and l NOTIN le *) + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + ) >> + subgoal `?n_l'. trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l'` >- ( + Cases_on `trs_to_s_count_ls m ms ({l} UNION le) s n 0` >> ( + fs [oadd_def] + ) + ) >> + subgoal `?ms'''. m.weak s ({l} UNION le) ms'''` >- ( + (* Since "?n_l. trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n" (i.e. s is somewhere between ms and ms') + * and s <> ms', weak transition from s to + * ({l} UNION le) will encounter ms' or some earlier state with pc l *) + metis_tac [loop_lemma_1] + ) >> + subgoal `m.pc ms''' = l` >- ( + fs [abstract_partial_jgmt_def] >> metis_tac [] ) >> - rpt strip_tac >> ( - fs [] - ) >| [ - QSPECL_X_ASSUM ``!ms'' ms'3'. - m.pc ms'' = l ==> - invariant ms'' /\ C1 ms'' ==> - (?n. weak_rel_steps m ms'' ({l} UNION le) ms'3' n) ==> - m.pc ms'3' = l /\ invariant ms'3'`` [`EL i ms_list`, `EL (SUC i) ms_list`] >> - QSPECL_X_ASSUM ``!i. i < LENGTH ms_list ==> m.pc (EL i ms_list) = l`` [`i`] >> + qexists_tac `ms'''` >> + fs [] >> + subgoal `?n_l''. trs_to_s_count_ls m s ({l} UNION le) ms' n 0 = SOME n_l''` >- ( + Cases_on `trs_to_s_count_ls m s ({l} UNION le) ms' n 0` >> ( + fs [oadd_def] + ) + ) >> + subgoal `n_l'' > 0` >- ( + (* n_l'' must be at least one, since at the very least ms' is encountered *) + irule loop_lemma_7 >> + qexists_tac `({l} UNION le)` >> + qexists_tac `m` >> + qexists_tac `s` >> + qexists_tac `ms'` >> + qexists_tac `n` >> fs [] >> - rfs [] >> - QSPECL_X_ASSUM ``!i. _`` [`i`] >> - rfs [] >> - `?n. weak_rel_steps m (EL i ms_list) ({l} UNION le) (EL (SUC i) ms_list) n` suffices_by ( - fs [] - ) >> - qexists_tac `n'3'` >> - fs [arithmeticTheory.SUC_ONE_ADD], + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + ) >> + rpt strip_tac >| [ + (* The calls to trs_to_s_count_ls must return one greater and one lesser, respectively, preserving the equality. *) + imp_res_tac loop_lemma_2 >> + imp_res_tac loop_lemma_3 >> + fs [oadd_def], - Cases_on `C1 (EL (SUC i) ms_list)` >> ( - fs [] - ) >> - subgoal `invariant (EL (SUC i) ms_list)` >- ( - QSPECL_X_ASSUM ``!i. _`` [`i`] >> - QSPECL_X_ASSUM ``!i. _`` [`i`] >> - rfs [arithmeticTheory.SUC_ONE_ADD] >> - metis_tac [] - ) >> - PAT_X_ASSUM ``!ms ms'. _`` (fn thm => irule thm) >> - QSPECL_X_ASSUM ``!i. _`` [`i`] >> - Cases_on `SUC i = LENGTH ms_list - 1` >- ( - (* SUC i is last in ms_list *) - QSPECL_X_ASSUM ``!i. _`` [`SUC i`] >> - qexists_tac `EL (SUC i) ms_list` >> - fs [] >> - rfs [] >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_rel_steps_equiv thm)]) >> - metis_tac [weak_union_thm, pred_setTheory.IN_SING, weak_rel_steps_equiv] - ) >> - subgoal `SUC i < LENGTH ms_list - 1` >- ( - fs [] - ) >> - fs [] >> - qexists_tac `EL (SUC i) ms_list` >> - fs [arithmeticTheory.SUC_ONE_ADD] >> - metis_tac [] + (* By the contract for the looping case *) + fs [abstract_partial_jgmt_def] >> + metis_tac [], + + (* Encounters of l until le will be one lesser from ms'' compared to s *) + imp_res_tac loop_lemma_3 >> + fs [] ] ) >> -QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> -QSPECL_X_ASSUM ``!ms ms'. _`` [`EL (LENGTH ms_list − 1) ms_list`, `ms'`] >> -subgoal `MEM (EL (LENGTH ms_list − 1) ms_list) ms_list` >- ( - subgoal `LENGTH ms_list − 1 < LENGTH ms_list` >- ( - fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] +subgoal `abstract_jgmt m l le (\s'. (\s. oadd (trs_to_s_count_ls m ms ({l} UNION le) s n 0) + (trs_to_s_count_ls m s ({l} UNION le) ms' n 0) = SOME n_l /\ invariant s) s' /\ ~(C1 s')) post` >- ( + fs [abstract_jgmt_def] >> + rpt strip_tac >> + subgoal `s' <> ms'` >- ( + (* Since pc of s' is l, m.weak ms le ms' and l NOTIN le *) + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] ) >> - metis_tac [rich_listTheory.EL_MEM] + subgoal `m.weak s' le ms'` >- ( + (* s' is reached from ms by between zero and n (exclusive) transitions: + * this means that we must be able to continue transitions until ms', without encountering + * le before *) + subgoal `?n_l'. trs_to_s_count_ls m ms ({l} UNION le) s' n 0 = SOME n_l'` >- ( + Cases_on `trs_to_s_count_ls m ms ({l} UNION le) s' n 0` >> ( + fs [oadd_def] + ) + ) >> + metis_tac [loop_lemma_4] + ) >> + fs [abstract_partial_jgmt_def] >> + QSPECL_X_ASSUM ``!ms ms'. m.pc ms = l ==> invariant ms /\ ~C1 ms ==> m.weak ms le ms' ==> post ms'`` [`s'`, `ms'`] >> + gs [] >> + qexists_tac `ms'` >> + metis_tac [] ) >> -rfs [] >> -Cases_on `C1 (EL (LENGTH ms_list − 1) ms_list)` >> ( - fs [] >> - QSPECL_X_ASSUM ``!i. _`` [`LENGTH ms_list − 1`] >> - QSPECL_X_ASSUM ``!i. _`` [`LENGTH ms_list − 1`] >> - fs [] >> - rfs [] >> - fs [] -) +imp_res_tac abstract_loop_rule_thm >> +fs [abstract_jgmt_def] >> +(* TODO: Should be provable using trs_to_ls m ({l} UNION le) ms n (SUC n_l) = SOME ms' *) +QSPECL_X_ASSUM ``!s. m.pc s = l ==> _`` [`ms`] >> +subgoal `trs_to_s_count_ls m ms ({l} UNION le) ms n 0 = SOME 0` >- ( + fs [loop_lemma_5] +) >> +gs [oadd_def] >> +metis_tac [weak_unique_thm] QED val _ = export_theory(); From 8f2c98c92ce3dbcc5c62862f2fe6570f2cfd315f Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 16 May 2022 16:01:06 +0200 Subject: [PATCH 0102/1015] Updates to partial correctness logic --- .../abstract_hoare_logic_partialScript.sml | 116 ++++++++++++++---- 1 file changed, 91 insertions(+), 25 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 3cc458444..f00efd879 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -861,17 +861,18 @@ End * reached, counting the number of times ls has been encountered * in the process *) Definition trs_to_s_count_ls_def: - (trs_to_s_count_ls mod ms ls s 0 n_ls = SOME n_ls) /\ - (trs_to_s_count_ls mod ms ls s (SUC n) n_ls = - if ms = s - then SOME n_ls - else - (case mod.trs ms of - NONE => NONE - | SOME ms' => - if mod.pc ms' IN ls - then trs_to_s_count_ls mod ms' ls s n (SUC n_ls) - else trs_to_s_count_ls mod ms' ls s n n_ls)) + (trs_to_s_count_ls m ms ls ms' 0 (n_ls:num) = NONE) /\ + (trs_to_s_count_ls m ms ls ms' (SUC n) n_ls = + (case m.trs ms of + NONE => NONE + | SOME ms'' => + if m.pc ms'' IN ls + then if ms'' = ms' + then SOME (SUC n_ls) + else trs_to_s_count_ls m ms'' ls ms' n (SUC n_ls) + else if ms'' = ms' + then SOME n_ls + else trs_to_s_count_ls m ms'' ls ms' n n_ls)) End (* TODO: Overkill? *) @@ -891,14 +892,15 @@ Proof cheat QED +(* TODO: You will likely need a lemma stating that all states reached with n or fewer transitions + * from ms are distinct. *) + Theorem loop_lemma_1: !m. weak_model m ==> - !ms s ms' l le n n_l. - m.weak ms le ms' ==> - s <> ms' ==> - trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l ==> - ?s'. m.weak s ({l} UNION le) s' + !ms ms' ls n n_l. + trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> + m.weak ms ls ms' Proof cheat QED @@ -960,14 +962,67 @@ Proof cheat QED +(* Maybe these are needed: +Theorem loop_lemma_7a: + !m. + weak_model m ==> + !ms ls ms' n n' n_l n_l'. + trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> + trs_to_s_count_ls m ms ls ms' n' 0 = SOME n_l' ==> + n' >= n ==> + n_l' >= n_l +Proof +cheat +QED + +Theorem loop_lemma_7b: + !m. + weak_model m ==> + !ms ls ms' n_l. + m.pc ms' IN ls ==> + trs_to_s_count_ls m ms ls ms' 1 0 = SOME n_l ==> + n_l = 1 +Proof +cheat +QED + +Theorem loop_lemma_7c: + !m. + weak_model m ==> + !ms ls ms' n n_l. + trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> + n' <= n ==> + ?n_l'. trs_to_s_count_ls m ms ls ms' n' 0 = SOME n_l +Proof +cheat +QED +*) + Theorem loop_lemma_7: !m. weak_model m ==> !ms ls ms' n n_l. trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> - m.pc ms' IN ls ==> + ms <> ms' ==> + m.pc ms' IN ls ==> n_l > 0 Proof +(* +rpt strip_tac >> +completeInduct_on `n` >| + rpt strip_tac >> + QSPECL_X_ASSUM ``!m'. _`` [`PRE n`] >> + Cases_on `n` >> ( + fs [trs_to_s_count_ls_def] + ) >> + Cases_on `m.trs ms` >> ( + fs [] + ) >> + Cases_on `m.trs ms` >> ( + fs [] + ) >> + fs [] >> +*) cheat QED @@ -1026,11 +1081,27 @@ subgoal `abstract_loop_jgmt m l le (\s. oadd (trs_to_s_count_ls m ms ({l} UNION fs [oadd_def] ) ) >> + subgoal `?n_l''. trs_to_s_count_ls m s ({l} UNION le) ms' n 0 = SOME n_l''` >- ( + Cases_on `trs_to_s_count_ls m s ({l} UNION le) ms' n 0` >> ( + fs [oadd_def] + ) + ) >> subgoal `?ms'''. m.weak s ({l} UNION le) ms'''` >- ( - (* Since "?n_l. trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n" (i.e. s is somewhere between ms and ms') + (* Since "?n_l. trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l" (i.e. s is somewhere between ms and ms') * and s <> ms', weak transition from s to * ({l} UNION le) will encounter ms' or some earlier state with pc l *) - metis_tac [loop_lemma_1] + ONCE_REWRITE_TAC [pred_setTheory.UNION_COMM] >> + irule weak_superset_thm >> + fs [] >> + qexists_tac `ms'` >> + irule weak_union2_thm >> + fs [] >> + conj_tac >| [ + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm], + + qexists_tac `{l}` >> + metis_tac [loop_lemma_1] + ] ) >> subgoal `m.pc ms''' = l` >- ( fs [abstract_partial_jgmt_def] >> @@ -1038,11 +1109,6 @@ subgoal `abstract_loop_jgmt m l le (\s. oadd (trs_to_s_count_ls m ms ({l} UNION ) >> qexists_tac `ms'''` >> fs [] >> - subgoal `?n_l''. trs_to_s_count_ls m s ({l} UNION le) ms' n 0 = SOME n_l''` >- ( - Cases_on `trs_to_s_count_ls m s ({l} UNION le) ms' n 0` >> ( - fs [oadd_def] - ) - ) >> subgoal `n_l'' > 0` >- ( (* n_l'' must be at least one, since at the very least ms' is encountered *) irule loop_lemma_7 >> @@ -1089,7 +1155,7 @@ subgoal `abstract_jgmt m l le (\s'. (\s. oadd (trs_to_s_count_ls m ms ({l} UNION metis_tac [loop_lemma_4] ) >> fs [abstract_partial_jgmt_def] >> - QSPECL_X_ASSUM ``!ms ms'. m.pc ms = l ==> invariant ms /\ ~C1 ms ==> m.weak ms le ms' ==> post ms'`` [`s'`, `ms'`] >> + QSPECL_X_ASSUM ``!ms ms'. m.pc ms = l ==> invariant ms /\ ~C1 ms ==> m.weak ms le ms' ==> post ms'`` [`s'`, `ms'`] >> gs [] >> qexists_tac `ms'` >> metis_tac [] From db00730f96c6f4ad6b75b76f7f69d514dee0612b Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 24 May 2022 16:38:35 +0200 Subject: [PATCH 0103/1015] More notes on run-oriented loop rule proof for partial correctness, nicer loop rule proof for total correctness --- .../abstract_hoare_logicScript.sml | 193 ++++++++---------- .../abstract_hoare_logic_partialScript.sml | 89 ++++++++ 2 files changed, 178 insertions(+), 104 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index 4933fe419..1d4d519f2 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -172,7 +172,8 @@ val abstract_jgmt_def = Define ` (post ms')) `; - +(* TODO: Can this be rephrased better? + * Antecedents guarantee swapping transition system of ANY contract. *) val abstract_weak_model_comp_rule_thm = store_thm("abstract_weak_model_comp_rule_thm", ``!m n l ls pre post. weak_model m ==> @@ -203,9 +204,9 @@ val abstract_case_rule_thm = prove(`` abstract_jgmt m l ls pre post ``, -REPEAT STRIP_TAC >> -FULL_SIMP_TAC std_ss [abstract_jgmt_def] >> -METIS_TAC [] +rpt strip_tac >> +fs [abstract_jgmt_def] >> +metis_tac [] ); val abstract_conseq_rule_thm = @@ -219,9 +220,9 @@ val abstract_conseq_rule_thm = abstract_jgmt m l ls pre2 post2 ``, -SIMP_TAC std_ss [abstract_jgmt_def] >> -REPEAT STRIP_TAC >> -METIS_TAC [weak_pc_in_thm] +rpt strip_tac >> +fs [abstract_jgmt_def] >> +metis_tac [weak_pc_in_thm] ); @@ -246,27 +247,29 @@ val abstract_seq_rule_thm = store_thm("abstract_seq_rule_thm", ``!m l ls1 ls2 pre post. weak_model m ==> abstract_jgmt m l (ls1 UNION ls2) pre post ==> - (!l1. (l1 IN ls1) ==> - (abstract_jgmt m l1 ls2 post post)) ==> + (!l1. + l1 IN ls1 ==> + abstract_jgmt m l1 ls2 post post + ) ==> abstract_jgmt m l ls2 pre post``, REPEAT STRIP_TAC >> SIMP_TAC std_ss [abstract_jgmt_def] >> REPEAT STRIP_TAC >> -PAT_X_ASSUM ``(abstract_jgmt m l (ls1 UNION ls2) pre post)`` +PAT_X_ASSUM ``abstract_jgmt m l (ls1 UNION ls2) pre post`` (fn thm => ASSUME_TAC (SIMP_RULE std_ss [abstract_jgmt_def] thm)) >> -QSPECL_X_ASSUM ``!x.P`` [`ms`] >> +QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> REV_FULL_SIMP_TAC std_ss [] >> -Cases_on `(m.pc ms') IN ls2` >- ( +Cases_on `m.pc ms' IN ls2` >- ( METIS_TAC [weak_union2_thm] ) >> -Q.SUBGOAL_THEN `(m.pc ms') IN ls1` ASSUME_TAC >- ( +subgoal `m.pc ms' IN ls1` >- ( METIS_TAC [weak_union_thm, weak_pc_in_thm] ) >> QSPECL_X_ASSUM ``!l1. _`` [`m.pc ms'`] >> REV_FULL_SIMP_TAC std_ss [abstract_jgmt_def] >> QSPECL_X_ASSUM ``!m. _`` [`ms'`] >> -REV_FULL_SIMP_TAC std_ss[] >> +REV_FULL_SIMP_TAC std_ss [] >> ASSUME_TAC (Q.SPECL [`m`] weak_comp_thm) >> METIS_TAC [] ); @@ -325,123 +328,105 @@ val (loop_fun_eqns, loop_fun_ind) = Defn.tprove(loop_fun_defn, val abstract_loop_jgmt_def = Define ` abstract_loop_jgmt m l le invariant C1 var = - ((~(l IN le)) /\ - (!x. (abstract_jgmt m l ({l} UNION le) (\ms. (invariant ms) /\ (C1 ms) /\ ((var ms) = x:num)) - (\ms.(((m.pc ms)=l) /\ (invariant ms) /\ ((var ms) < x) /\ ((var ms) >= 0)))))) + (~(l IN le) /\ + !x. abstract_jgmt m l ({l} UNION le) (\ms. invariant ms /\ C1 ms /\ var ms = x:num) + (\ms. m.pc ms = l /\ invariant ms /\ var ms < x /\ var ms >= 0)) `; -val inductive_invariant_goal = -(fst o dest_imp o concl ) ( - Q.SPEC `(\m ms var l le invariant C1. +(* TODO: Try removing C1 from the last conjunct, see what happens? *) +val loop_fun_ind_spec = + Q.SPEC `\m ms var l le invariant C1. weak_model m ==> abstract_loop_jgmt m l le invariant C1 var ==> - abstract_jgmt m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> - ((invariant ms) /\ ((m.pc ms) = l) /\ (C1 ms)) ==> - (?ms'. ((m.weak ms le ms') /\ (post ms'))))` - loop_fun_ind -); + abstract_jgmt m l le (\ms. invariant ms /\ ~C1 ms) post ==> + (invariant ms /\ m.pc ms = l /\ C1 ms) ==> + (?ms'. m.weak ms le ms' /\ post ms')` loop_fun_ind; + + +val inductive_invariant_goal = fst $ dest_imp $ concl loop_fun_ind_spec; val inductive_invariant = prove(`` -^inductive_invariant_goal + ^inductive_invariant_goal ``, -REPEAT STRIP_TAC >> -FULL_SIMP_TAC std_ss [] >> -REPEAT STRIP_TAC >> -(* We first prove that one iteration works *) -SUBGOAL_THEN ``(loop_step m ms var l le invariant C1) <> {}`` ASSUME_TAC >- ( - SIMP_TAC std_ss [loop_step_def, LET_DEF] >> - FULL_SIMP_TAC std_ss [abstract_loop_jgmt_def] >> - QSPECL_X_ASSUM ``!x. _`` [`(var (ms)):num`] >> - FULL_SIMP_TAC std_ss [abstract_jgmt_def] >> - QSPECL_X_ASSUM ``!x. _`` [`ms`] >> - REV_FULL_SIMP_TAC std_ss [] >> - FULL_SIMP_TAC std_ss [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> - EXISTS_TAC ``ms'':'a`` >> - FULL_SIMP_TAC std_ss [pred_setTheory.SPECIFICATION] +rpt strip_tac >> +fs [] >> +rpt strip_tac >> +(* We first prove that one iteration works (first antecedent of induction hypothesis): + * OK since C1 holds in ms, then use loop judgment to obtain + * witness *) +subgoal `loop_step m ms var l le invariant C1 <> {}` >- ( + simp [loop_step_def, LET_DEF] >> + fs [abstract_loop_jgmt_def] >> + QSPECL_X_ASSUM ``!x. _`` [`(var ms):num`] >> + fs [abstract_jgmt_def] >> + QSPECL_X_ASSUM ``!ms. _`` [`ms`] >> + rfs [] >> + fs [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> + qexists_tac `ms'':'a` >> + fs [pred_setTheory.SPECIFICATION] ) >> -FULL_SIMP_TAC std_ss [] >> - -Q.ABBREV_TAC `MS' = (loop_step m ms var l le invariant C1)` >> +(* There first four antecedents of the induction hypothesis are now in place *) +fs [] >> +(* Let ms' be the state at the next loop iteration *) +Q.ABBREV_TAC `MS' = loop_step m ms var l le invariant C1` >> Q.ABBREV_TAC `ms' = CHOICE MS'` >> - -(* We prove that the invariant is preserved *) -SUBGOAL_THEN ``(loop_step m ms var l le invariant C1) ms'`` ASSUME_TAC >- ( - FULL_SIMP_TAC std_ss [Abbr `ms'`] >> - ASSUME_TAC (ISPEC ``MS':'a->bool`` pred_setTheory.CHOICE_DEF) >> - REV_FULL_SIMP_TAC std_ss [pred_setTheory.SPECIFICATION] +subgoal `loop_step m ms var l le invariant C1 ms'` >- ( + fs [Abbr `ms'`] >> + ONCE_REWRITE_TAC [GSYM pred_setTheory.SPECIFICATION] >> + metis_tac [pred_setTheory.CHOICE_DEF] ) >> -Q.SUBGOAL_THEN `invariant ms'` ASSUME_TAC >- ( - FULL_SIMP_TAC std_ss [ loop_step_def, LET_DEF] +(* We then prove that the invariant is preserved and loop + * point is l + * (follows from ms' being the result of a loop_step) *) +subgoal `invariant ms' /\ (m.pc ms') = l` >- ( + fs [loop_step_def, LET_DEF] ) >> -FULL_SIMP_TAC std_ss [] >> -Q.SUBGOAL_THEN `(m.pc ms') = l` ASSUME_TAC >- ( - FULL_SIMP_TAC std_ss [ loop_step_def, LET_DEF] -) >> -FULL_SIMP_TAC std_ss [] >> - -(* If we exit the loop *) -Cases_on `~ (C1 ms')` >- ( - (FULL_SIMP_TAC std_ss [loop_step_def, LET_DEF]) >> - (FULL_SIMP_TAC std_ss [abstract_jgmt_def]) >> - QSPECL_X_ASSUM ``!x. _`` [`ms'`] >> - (REV_FULL_SIMP_TAC std_ss []) >> - ASSUME_TAC (Q.SPECL [`m`] weak_comp_thm) >> - REV_FULL_SIMP_TAC std_ss [] >> - QSPECL_X_ASSUM ``!x. _`` [`ms`, `{l}`, `le`, `ms'`, `ms''`] >> - REV_FULL_SIMP_TAC (std_ss) [SINGLETONS_UNION_thm] >> - Q.SUBGOAL_THEN `l NOTIN le` (FULLSIMP_BY_THM std_ss) >- ( - FULL_SIMP_TAC std_ss [abstract_loop_jgmt_def, pred_setTheory.IN_SING] - ) >> - METIS_TAC [] -) >> ( - FULL_SIMP_TAC std_ss [] -) >> ( - FULL_SIMP_TAC std_ss [loop_step_def, LET_DEF] -) >> -ASSUME_TAC (Q.SPECL [`m`] weak_comp_thm) >> -REV_FULL_SIMP_TAC std_ss [] >> -QSPECL_X_ASSUM ``!x. _`` [`ms`, `{l}`, `le`, `ms'`, `ms''`] >> -REV_FULL_SIMP_TAC (std_ss) [SINGLETONS_UNION_thm] >> - Q.SUBGOAL_THEN `l NOTIN le` (FULLSIMP_BY_THM std_ss) >- ( - FULL_SIMP_TAC std_ss [abstract_loop_jgmt_def, pred_setTheory.IN_SING] +fs [] >> +(* C1 holding in ms' remains to prove for the induction hypothesis. + * However, if C1 does not hold in ms', the loop exit contract can be used to + * complete the proof directly, so a case split is done. + * For both cases, weak_comp_thm is used to connect ms to ms'' via ms'. *) +Cases_on `~C1 ms'` >| [ + fs [loop_step_def, LET_DEF, abstract_jgmt_def] >> + QSPECL_X_ASSUM ``!ms. _`` [`ms'`] >> + rfs [], + + fs [loop_step_def, LET_DEF] +] >> ( + `m.weak ms le ms''` suffices_by ( + metis_tac [] ) >> - METIS_TAC [] + irule weak_comp_thm >> + fs [] >> + qexistsl_tac [`{l}`, `ms'`] >> + Q.SUBGOAL_THEN `l NOTIN le` (fn thm => fs [thm]) >- ( + fs [abstract_loop_jgmt_def, pred_setTheory.IN_SING] + ) +) ); - - - -val abstract_loop_rule_tmp_thm = -MP -(Q.SPEC `(\m ms var l le invariant C1. -weak_model m ==> -abstract_loop_jgmt m l le invariant C1 var ==> -abstract_jgmt m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> -((invariant ms) /\ ((m.pc ms) = l) /\ (C1 ms)) ==> - (?ms'. ((m.weak ms le ms') /\ (post ms'))))` loop_fun_ind) inductive_invariant; +(* Now just some final touches to get the theorem in the exact shape we want *) +val abstract_loop_rule_tmp_thm = MP loop_fun_ind_spec inductive_invariant; val abstract_loop_rule_thm = store_thm("abstract_loop_rule_thm", ``!m. weak_model m ==> !l le invariant C1 var post. abstract_loop_jgmt m l le invariant C1 var ==> - abstract_jgmt m l le (\ms. (invariant ms) /\ (~(C1 ms))) post ==> + abstract_jgmt m l le (\ms. invariant ms /\ ~C1 ms) post ==> abstract_jgmt m l le invariant post``, -REPEAT STRIP_TAC >> -SIMP_TAC std_ss [abstract_jgmt_def] >> -REPEAT STRIP_TAC >> +rpt strip_tac >> +simp [abstract_jgmt_def] >> +rpt strip_tac >> ASSUME_TAC (Q.SPECL [`m`, `ms`, `var`, `l`, `le`, `invariant`, `C1`] abstract_loop_rule_tmp_thm) >> -FULL_SIMP_TAC std_ss [] >> -REV_FULL_SIMP_TAC std_ss [] >> +rfs [] >> Cases_on `C1 ms` >- ( - FULL_SIMP_TAC std_ss [] >> - Q.EXISTS_TAC `ms'`>> - FULL_SIMP_TAC std_ss [] + metis_tac [] ) >> -FULL_SIMP_TAC std_ss [abstract_jgmt_def] +fs [abstract_jgmt_def] ); val _ = export_theory(); diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index f00efd879..c9f85bceb 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -875,6 +875,17 @@ Definition trs_to_s_count_ls_def: else trs_to_s_count_ls m ms'' ls ms' n n_ls)) End +Definition trs_n_count_ls_def: + (trs_n_count_ls m ms ls 0 (n_ls:num) = SOME n_ls) /\ + (trs_n_count_ls m ms ls (SUC n) n_ls = + (case m.trs ms of + NONE => NONE + | SOME ms' => + if m.pc ms' IN ls + then trs_n_count_ls m ms' ls n (SUC n_ls) + else trs_n_count_ls m ms' ls n n_ls)) +End + (* TODO: Overkill? *) Definition oadd_def: (oadd NONE _ = NONE) /\ @@ -952,6 +963,7 @@ Proof cheat QED +(* TODO: Generalize ({l} UNION ls) to ls' *) Theorem loop_lemma_6: !m. weak_model m ==> @@ -959,6 +971,20 @@ Theorem loop_lemma_6: weak_rel_steps m ms ls ms' n ==> ?n_l. trs_to_s_count_ls m ms ({l} UNION ls) ms' n 0 = SOME n_l Proof +(* This requires that: + * ms' is reached with no more than n steps + * for all n' < n, ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' *) +rpt strip_tac >> +cheat +QED + +Theorem loop_n_lemma_6: + !m. + weak_model m ==> + !ms ls l ms' n. + weak_rel_steps m ms ls ms' n ==> + ?n_l. trs_n_count_ls m ms ({l} UNION ls) n 0 = SOME n_l +Proof cheat QED @@ -1026,6 +1052,30 @@ completeInduct_on `n` >| cheat QED +(* TODO: For run-oriented proof: *) + +Definition run_to_ls_def: + (run_to_ls m ls ms = + if ?n. n > 0 /\ (?ms'. FUNPOW_OPT m.trs n ms = SOME ms' /\ m.pc ms' IN ls /\ !n'. n' < n ==> (?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls )) + then FUNPOW_OPT m.trs (@n. n > 0 /\ (?ms'. FUNPOW_OPT m.trs n ms = SOME ms' /\ m.pc ms' IN ls /\ !n'. n' < n ==> (?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls ))) ms + else NONE) +End + +Definition run_to_ls_n_def: + (run_to_ls_m m ls ms n = FUNPOW_OPT (run_to_ls m ls) n ms) +End + +(* Invariant: *) +(* +``\s. (@n. run_to_ls_m m ({l} UNION le) ms n = SOME s) + + (@n. run_to_ls_m m ({l} UNION le) s n = SOME ms') = n_l`` +*) + +(* Variant: *) +(* +``\s. (@n. run_to_ls_m m ({l} UNION le) s n = SOME ms')`` +*) + Theorem weak_partial_loop_rule_thm: !m. weak_model m ==> @@ -1034,6 +1084,45 @@ Theorem weak_partial_loop_rule_thm: abstract_partial_jgmt m l le (\ms. invariant ms /\ ~(C1 ms)) post ==> abstract_partial_jgmt m l le invariant post Proof +(* Version with trs_n invariant: +rpt strip_tac >> +SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +rpt strip_tac >> +fs [weak_partial_loop_contract_def] >> +subgoal `?ms''. m.weak ms ({l} UNION le) ms''` >- ( + (* There is at least ms', possibly another state if l is encountered before *) + metis_tac [weak_superset_thm, pred_setTheory.UNION_COMM] +) >> +Cases_on `m.pc ms'' IN le` >- ( + (* If le was reached without encountering l, we win immediately *) + fs [abstract_partial_jgmt_def] >> + res_tac >> + Cases_on `~C1 ms` >> ( + metis_tac [] + ) +) >> +subgoal `m.pc ms'' = l` >- ( + imp_res_tac weak_pc_in_thm >> + gs [pred_setTheory.IN_UNION] +) >> +(* Needed to establish n *) +subgoal `?n. weak_rel_steps m ms le ms' n /\ n > 0` >- ( + (* Since m.weak to le connects ms and ms' by some non-zero number of transitions *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> + qexists_tac `n` >> + fs [weak_rel_steps_def] +) >> +(* Needed to establish n_l *) +subgoal `?n_l. trs_n_count_ls m ms ({l} UNION le) n 0 = SOME n_l` >- ( + metis_tac [loop_n_lemma_6] +) >> +subgoal `abstract_loop_jgmt m l le (\s. ?n'. FUNPOW_OPT m.trs n' ms = SOME s /\ oadd (trs_n_count_ls m ms ({l} UNION le) n' 0) (trs_n_count_ls m s ({l} UNION le) (n-n') 0) = SOME n_l) C1 + (\s. THE (trs_to_s_count_ls m s ({l} UNION le) ms' n 0))` >- ( + cheat +) >> +cheat +*) + rpt strip_tac >> SIMP_TAC std_ss [abstract_partial_jgmt_def] >> rpt strip_tac >> From 6b11556912a0660230bf63652f24579ad3443fad Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 24 May 2022 16:55:24 +0200 Subject: [PATCH 0104/1015] Even nicer loop rule proof for total correctness --- .../abstract_hoare_logicScript.sml | 21 ++++++++----------- 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index 1d4d519f2..a4702e984 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -314,7 +314,7 @@ Defn.tgoal loop_fun_defn *) val (loop_fun_eqns, loop_fun_ind) = Defn.tprove(loop_fun_defn, FULL_SIMP_TAC std_ss [loop_step_def] >> - WF_REL_TAC `measure (\(m, ms,var,l,le,invariant,C1). var ms)` >> + WF_REL_TAC `measure (\(m,ms,var,l,le,invariant,C1). var ms)` >> REPEAT STRIP_TAC >> REV_FULL_SIMP_TAC std_ss [LET_DEF] >> Q.ABBREV_TAC `MS' = (\ms'. @@ -333,13 +333,15 @@ val abstract_loop_jgmt_def = Define ` (\ms. m.pc ms = l /\ invariant ms /\ var ms < x /\ var ms >= 0)) `; -(* TODO: Try removing C1 from the last conjunct, see what happens? *) +(* Note that due to loop_fun_ind relating states ms and ms' at loop points, + * ms needs to be exposed also here. Either this can be explicitly specified + * in the precondition of the conclusion, or the definition can be unfolded, like here *) val loop_fun_ind_spec = Q.SPEC `\m ms var l le invariant C1. weak_model m ==> abstract_loop_jgmt m l le invariant C1 var ==> abstract_jgmt m l le (\ms. invariant ms /\ ~C1 ms) post ==> - (invariant ms /\ m.pc ms = l /\ C1 ms) ==> + (invariant ms /\ m.pc ms = l) ==> (?ms'. m.weak ms le ms' /\ post ms')` loop_fun_ind; @@ -353,6 +355,9 @@ val inductive_invariant = prove(`` rpt strip_tac >> fs [] >> rpt strip_tac >> +Cases_on `~C1 ms` >- ( + fs [abstract_jgmt_def] +) >> (* We first prove that one iteration works (first antecedent of induction hypothesis): * OK since C1 holds in ms, then use loop judgment to obtain * witness *) @@ -418,15 +423,7 @@ val abstract_loop_rule_thm = store_thm("abstract_loop_rule_thm", abstract_jgmt m l le (\ms. invariant ms /\ ~C1 ms) post ==> abstract_jgmt m l le invariant post``, -rpt strip_tac >> -simp [abstract_jgmt_def] >> -rpt strip_tac >> -ASSUME_TAC (Q.SPECL [`m`, `ms`, `var`, `l`, `le`, `invariant`, `C1`] abstract_loop_rule_tmp_thm) >> -rfs [] >> -Cases_on `C1 ms` >- ( - metis_tac [] -) >> -fs [abstract_jgmt_def] +metis_tac [abstract_jgmt_def, abstract_loop_rule_tmp_thm] ); val _ = export_theory(); From d10fe8ea6f3df7fd32643232d129116c259db418 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 26 May 2022 10:36:40 +0200 Subject: [PATCH 0105/1015] New proof style for partial correctness loop rule --- .../abstract_hoare_logicScript.sml | 30 +- .../abstract_hoare_logic_partialScript.sml | 616 +++++++----------- 2 files changed, 239 insertions(+), 407 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index a4702e984..537f74d85 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -389,26 +389,16 @@ subgoal `invariant ms' /\ (m.pc ms') = l` >- ( fs [loop_step_def, LET_DEF] ) >> fs [] >> -(* C1 holding in ms' remains to prove for the induction hypothesis. - * However, if C1 does not hold in ms', the loop exit contract can be used to - * complete the proof directly, so a case split is done. - * For both cases, weak_comp_thm is used to connect ms to ms'' via ms'. *) -Cases_on `~C1 ms'` >| [ - fs [loop_step_def, LET_DEF, abstract_jgmt_def] >> - QSPECL_X_ASSUM ``!ms. _`` [`ms'`] >> - rfs [], - - fs [loop_step_def, LET_DEF] -] >> ( - `m.weak ms le ms''` suffices_by ( - metis_tac [] - ) >> - irule weak_comp_thm >> - fs [] >> - qexistsl_tac [`{l}`, `ms'`] >> - Q.SUBGOAL_THEN `l NOTIN le` (fn thm => fs [thm]) >- ( - fs [abstract_loop_jgmt_def, pred_setTheory.IN_SING] - ) +(* For both cases, weak_comp_thm is used to connect ms to ms'' via ms'. *) +fs [loop_step_def, LET_DEF] >> +`m.weak ms le ms''` suffices_by ( + metis_tac [] +) >> +irule weak_comp_thm >> +fs [] >> +qexistsl_tac [`{l}`, `ms'`] >> +Q.SUBGOAL_THEN `l NOTIN le` (fn thm => fs [thm]) >- ( + fs [abstract_loop_jgmt_def, pred_setTheory.IN_SING] ) ); diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index c9f85bceb..12e04f579 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -640,60 +640,6 @@ Proof fs [abstract_jgmt_imp_partial_triple] QED -(* Discussion version: - !m l ls pre post. - weak_model m ==> - (!ms. m.pc ms = l /\ pre ms ==> (?ms'. m.weak ms ls ms') ==> - abstract_partial_jgmt m l ls pre post ==> - abstract_jgmt m l ls pre post) -*) -Theorem partial_to_total: - !m l ls pre post. - weak_model m ==> - (!ms. m.pc ms = l /\ pre ms ==> ?ms'. m.weak ms ls ms') ==> - abstract_partial_jgmt m l ls pre post ==> - abstract_jgmt m l ls pre post -Proof -cheat -QED - -(* !!!!!!!!!!!!!!!!!!!!! *) -(* Suggested lemma to factor out from total correctness version of seq rule: *) -Theorem seq_lemma: -!m ls1 ls2 post. -weak_model m ==> -!ms. -?ms'. m.weak ms (ls1 UNION ls2) ms' /\ post ms' /\ -(m.pc ms' NOTIN ls2 ==> ?ms''. m.weak ms' ls2 ms'' /\ post ms'') ==> -?ms'''. m.weak ms ls2 ms''' /\ post ms''' -Proof -cheat -QED - -(* Suggested lemmata to use: - - m.weak ms ls ms' ==> ?ms''. m.weak ms (ls1 UNION ls2) ms'' - - (* Same as seq_lemma? *) - ?ms''. m.weak ms ls' ms'' /\ (!ms'''. m.weak ms ls' ms''' => post ms''') ==> ?ms''''. m.weak ms ls' ms'''' /\ post ms'''' - -*) - -(* If we know that ms terminates, then we maybe could prove the premises of the - * total-correctnesss seq rule in the following format: - - [pre a /\ a = ms]l->(ls1 U ls2)[post a] - !l1 in ls1. [post a /\ weak ms ls1 a /\ a in l1]l1->ls2[post a] - - * No, second premise must have identical pre-and postcondition... - *) - -(* Another lemma suggestion: identical to intermediate label lemma? - - m.weak ms ls ms' /\ m.weak ms ls U ls' ms'' /\ ms''<>ms' [ms'' not in ls'] ==> - m.weak ms'' ls ms' -*) - Theorem weak_partial_seq_rule_thm: !m l ls1 ls2 pre post. weak_model m ==> @@ -702,25 +648,6 @@ Theorem weak_partial_seq_rule_thm: (abstract_partial_jgmt m l1 ls2 post post)) ==> abstract_partial_jgmt m l ls2 pre post Proof -(* Trying to use seq_lemma: -rpt strip_tac >> -FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -rpt strip_tac >> -imp_res_tac seq_lemma >> -QSPECL_X_ASSUM ``!post ms ls2 ls1. _`` [`post`, `ms`, `ls2`, `ls1`] >> -fs [] >> -subgoal `?ms'. m.weak ms (ls1 UNION ls2) ms'` >- ( - cheat -) >> -subgoal `post ms'3'` >- ( - cheat -) >> -Cases_on `m.pc ms'3' IN ls2` >- ( - cheat -) >> -(* TODO: Probably does not work *) -*) - rpt strip_tac >> SIMP_TAC std_ss [abstract_partial_jgmt_def] >> rpt strip_tac >> @@ -776,48 +703,6 @@ subgoal `m.pc ms' IN ls2` >- ( ) >> metis_tac [] -(* Straight-up reuse of total-correctness rule: *) -(* -rpt strip_tac >> -(* Experiment with trying to case split on termination: -Cases_on ‘(!ms. m.pc ms = l /\ pre ms ==> ~(?ms'. m.weak ms ls2 ms'))’ >- ( - fs [abstract_partial_jgmt_def] -) >> -*) -(* Experiment with trying to case split on termination: -subgoal ‘(!ms. m.pc ms = l /\ pre ms ==> (?ms'. m.weak ms ls2 ms'))’ >- ( - cheat -) >> -*) -fs [] >> -irule total_to_partial >> -fs [] >> -irule abstract_seq_rule_thm >> -fs [] >> -qexists_tac ‘ls1’ >> -conj_tac >| [ - rpt strip_tac >> - irule partial_to_total >> - fs [] >> - rpt strip_tac >> - QSPECL_X_ASSUM ``!l1. l1 IN ls1 ==> _`` [`l1`] >> - rfs [abstract_partial_jgmt_def] >> - res_tac >> - (* What to do here: Existence of ms' such that m.weak ms ls2 ms' unclear *) - QSPECL_X_ASSUM `` !ms. m.pc ms = l /\ pre ms ==> ?ms'. m.weak ms ls2 ms'`` [`ms`] >> - fs [] >> - metis_tac [] - cheat, - - irule partial_to_total >> - fs [] >> - rpt strip_tac >> - fs [abstract_partial_jgmt_def] >> - res_tac >> - (* What to do here: Same problem as above *) - cheat -] -*) (* OLD, working proof: *) (* @@ -857,42 +742,6 @@ Definition weak_partial_loop_contract_def: (\ms. m.pc ms = l /\ invariant ms)) End -(* Applies trs a maximum of n_max times until state s has been - * reached, counting the number of times ls has been encountered - * in the process *) -Definition trs_to_s_count_ls_def: - (trs_to_s_count_ls m ms ls ms' 0 (n_ls:num) = NONE) /\ - (trs_to_s_count_ls m ms ls ms' (SUC n) n_ls = - (case m.trs ms of - NONE => NONE - | SOME ms'' => - if m.pc ms'' IN ls - then if ms'' = ms' - then SOME (SUC n_ls) - else trs_to_s_count_ls m ms'' ls ms' n (SUC n_ls) - else if ms'' = ms' - then SOME n_ls - else trs_to_s_count_ls m ms'' ls ms' n n_ls)) -End - -Definition trs_n_count_ls_def: - (trs_n_count_ls m ms ls 0 (n_ls:num) = SOME n_ls) /\ - (trs_n_count_ls m ms ls (SUC n) n_ls = - (case m.trs ms of - NONE => NONE - | SOME ms' => - if m.pc ms' IN ls - then trs_n_count_ls m ms' ls n (SUC n_ls) - else trs_n_count_ls m ms' ls n n_ls)) -End - -(* TODO: Overkill? *) -Definition oadd_def: - (oadd NONE _ = NONE) /\ - (oadd _ NONE = NONE) /\ - (oadd (SOME (n:num)) (SOME n') = SOME (n + n')) -End - Theorem weak_superset_thm: !m. weak_model m ==> @@ -903,178 +752,229 @@ Proof cheat QED -(* TODO: You will likely need a lemma stating that all states reached with n or fewer transitions - * from ms are distinct. *) +Definition ominus_def: + (ominus NONE _ = NONE) /\ + (ominus _ NONE = NONE) /\ + (ominus (SOME (n:num)) (SOME n') = SOME (n - n')) +End + +Definition weak_exec_def: + (weak_exec m ls ms = + let + MS' = m.weak ms ls + in + if MS' = {} + then NONE + else SOME (CHOICE MS')) +End + +Definition weak_exec_n_def: + (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) +End + +(* TODO: Can prove equivalence here? *) +Theorem weak_exec_exists: + !m. + weak_model m ==> + !ms ls ms'. + m.weak ms ls ms' ==> + weak_exec m ls ms = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_def] >> +subgoal `m.weak ms ls = {ms'}` >- ( + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> + metis_tac [weak_unique_thm] +) >> +fs [] +QED -Theorem loop_lemma_1: +(* TODO: Strengthen conclusion to state either ms'' is ms', or pc is in ls2? *) +Theorem weak_exec_exists_superset: !m. weak_model m ==> - !ms ms' ls n n_l. - trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> - m.weak ms ls ms' + !ms ls1 ls2 ms'. + m.weak ms ls1 ms' ==> + ?ms''. weak_exec m (ls1 UNION ls2) ms = SOME ms'' Proof +rpt strip_tac >> +fs [weak_exec_def] >> +(* OK: Either ms' is the result, or some other state with pc in ls2 was encountered before that *) cheat QED -(* TODO: Add all necessary antecedents... *) -Theorem loop_lemma_2: +Theorem weak_exec_n_exists_superset: !m. weak_model m ==> - !ms s ms''' l le n n_l. - l NOTIN le ==> - trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l ==> - m.weak s ({l} UNION le) ms'3' ==> - m.pc ms'3' = l ==> - trs_to_s_count_ls m ms ({l} UNION le) ms'3' n 0 = SOME (SUC n_l) + !ms ls1 ls2 ms'. + m.weak ms ls1 ms' ==> + ?n. (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n Proof +rpt strip_tac >> +(* OK: weak_exec_n is repeated applications of weak_exec. For every such application, + * either ms' was encountered, or ls2, in which case some further number of steps + * will encounter ms'. *) cheat QED -Theorem loop_lemma_3: + +Theorem weak_exec_least_nonzero: !m. weak_model m ==> - !ms s ms''' ms' l le n n_l. - l NOTIN le ==> - m.weak ms le ms' ==> - trs_to_s_count_ls m s ({l} UNION le) ms' n 0 = SOME n_l ==> - m.weak s ({l} UNION le) ms'3' ==> - m.pc ms'3' = l ==> - trs_to_s_count_ls m ms''' ({l} UNION le) ms' n 0 = SOME (PRE n_l) + !ms ls ms' n_l. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + ms <> ms' ==> + n_l > 0 Proof +rpt strip_tac >> +Cases_on `weak_exec_n m ms ls 0 = SOME ms'` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_def] +) >> +(* TODO: Should be trivial: P 0 = F ==> (OLEAST n. P n) = SOME n_l ==> n_l > 0 *) cheat QED -(* TODO: Needs to take into account number of transitions used *) -Theorem loop_lemma_4: + +Theorem weak_exec_sing_least_less: !m. weak_model m ==> - !ms s' ms' l le n n_l. - l NOTIN le ==> - m.weak ms le ms' ==> - trs_to_s_count_ls m ms ({l} UNION le) s' n 0 = SOME n_l ==> - m.weak s' le ms' + !ms ls ms' n_l. + SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms') ==> + ?n_l'. (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' /\ n_l' < n_l Proof +rpt strip_tac >> +(* OK: If ms' is uniquely encountered before n_l loop iterations, then + * there must be a least number of loop iterations such that ms' is + * encountered, and this number is less than n_l *) cheat QED -Theorem loop_lemma_5: + +Theorem weak_inter_exec: !m. weak_model m ==> - !ms ls n. - trs_to_s_count_ls m ms ls ms n 0 = SOME 0 + !ms le l n_l ms' s'. + m.weak ms le ms' ==> + (OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME ms') = SOME n_l ==> + SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME s') ==> + m.weak s' le ms' Proof +rpt strip_tac >> +(* OK: s' is a uniquely encountered (before n_l loop iterations) state, + * where n_l is the least amount of applications of weak_exec to ({l} UNION le) + * needed to exit the loop, + * therefore weak transition can continue from s' to the loop exit *) cheat QED -(* TODO: Generalize ({l} UNION ls) to ls' *) -Theorem loop_lemma_6: +(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) +Theorem weak_exec_incr: !m. weak_model m ==> - !ms ls l ms' n. - weak_rel_steps m ms ls ms' n ==> - ?n_l. trs_to_s_count_ls m ms ({l} UNION ls) ms' n 0 = SOME n_l + !ms ls ms' n_l ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + m.weak ms' ls ms'' ==> + weak_exec_n m ms ls (SUC n_l) = SOME ms'' Proof -(* This requires that: - * ms' is reached with no more than n steps - * for all n' < n, ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' *) rpt strip_tac >> +(* OK: ms'' reached by taking an additional weak transition from ms', + * itself reached in n_l weak transitions, can also be reached by taking + * n_l + 1 weak transitions *) cheat QED -Theorem loop_n_lemma_6: +(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) +Theorem weak_exec_incr_least: !m. weak_model m ==> - !ms ls l ms' n. - weak_rel_steps m ms ls ms' n ==> - ?n_l. trs_n_count_ls m ms ({l} UNION ls) n 0 = SOME n_l + !ms ls ms' n_l n_l' ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' ==> + m.weak ms' ls ms'' ==> + SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms'') ==> + n_l' < n_l ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME (SUC n_l') Proof +rpt strip_tac >> +(* OK: If ms' was first encountered at n_l' weak iterations to ls, and + * if one additional weak transition to ls goes to ms'', then if + * ms'' is uniquely encountered before n_l weak transitions to ls and n_l + * is greater than n_l', then SUC n_l' must be the least number of weak transitions + * needed to reach ms'' *) cheat QED -(* Maybe these are needed: -Theorem loop_lemma_7a: +(* TODO: m.weak ms ls2 ms' redundant? *) +Theorem weak_exec_uniqueness: !m. weak_model m ==> - !ms ls ms' n n' n_l n_l'. - trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> - trs_to_s_count_ls m ms ls ms' n' 0 = SOME n_l' ==> - n' >= n ==> - n_l' >= n_l + !ms ls1 ls2 ms' n_l. + m.weak ms ls2 ms' ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> + !n_l' ms''. n_l' < n_l ==> + weak_exec_n m ms (ls1 UNION ls2) n_l' = SOME ms'' ==> + SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') Proof +rpt strip_tac >> +(* OK: ms'' is a state encountered before n_l loop iterations, + * where n_l is the least amount of applications of weak_exec to ({l} UNION le) + * needed to exit the loop, + * therefore ms'' must have been uniquely encountered before n_l loop iterations, + * or there must have been a loop before ms' could ever be reached *) cheat QED -Theorem loop_lemma_7b: +(* Uses the fact that exit labels are disjoint from loop point to know that + * we have not yet exited the loop after another weak transition, i.e. the + * number of loops is still less than n_l *) +Theorem weak_exec_less_incr_superset: !m. weak_model m ==> - !ms ls ms' n_l. - m.pc ms' IN ls ==> - trs_to_s_count_ls m ms ls ms' 1 0 = SOME n_l ==> - n_l = 1 + !ms ls1 ls2 ms' ms'' ms''' n_l n_l'. + DISJOINT ls1 ls2 ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> + m.pc ms' IN ls2 ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') = SOME n_l' ==> + n_l' < n_l ==> + m.weak ms'' (ls1 UNION ls2) ms''' ==> + m.pc ms''' NOTIN ls2 ==> + SUC n_l' < n_l Proof cheat QED -Theorem loop_lemma_7c: +(* +Theorem weak_exec_less: !m. weak_model m ==> - !ms ls ms' n n_l. - trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> - n' <= n ==> - ?n_l'. trs_to_s_count_ls m ms ls ms' n' 0 = SOME n_l + !ms ls ms' n_l n_l'. + SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms') ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' ==> + n_l' < n_l Proof cheat QED *) -Theorem loop_lemma_7: +(* +Theorem weak_exec_comp1: !m. weak_model m ==> - !ms ls ms' n n_l. - trs_to_s_count_ls m ms ls ms' n 0 = SOME n_l ==> - ms <> ms' ==> - m.pc ms' IN ls ==> - n_l > 0 + !ms ls ms' n n' ms''. + weak_exec_n m ms ls n = SOME ms' ==> + weak_exec_n m ms ls n' = SOME ms'' ==> + n < n' ==> + weak_exec_n m ms ls (n - n') = SOME ms'' Proof -(* -rpt strip_tac >> -completeInduct_on `n` >| - rpt strip_tac >> - QSPECL_X_ASSUM ``!m'. _`` [`PRE n`] >> - Cases_on `n` >> ( - fs [trs_to_s_count_ls_def] - ) >> - Cases_on `m.trs ms` >> ( - fs [] - ) >> - Cases_on `m.trs ms` >> ( - fs [] - ) >> - fs [] >> -*) cheat QED +*) -(* TODO: For run-oriented proof: *) - -Definition run_to_ls_def: - (run_to_ls m ls ms = - if ?n. n > 0 /\ (?ms'. FUNPOW_OPT m.trs n ms = SOME ms' /\ m.pc ms' IN ls /\ !n'. n' < n ==> (?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls )) - then FUNPOW_OPT m.trs (@n. n > 0 /\ (?ms'. FUNPOW_OPT m.trs n ms = SOME ms' /\ m.pc ms' IN ls /\ !n'. n' < n ==> (?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls ))) ms - else NONE) -End - -Definition run_to_ls_n_def: - (run_to_ls_m m ls ms n = FUNPOW_OPT (run_to_ls m ls) n ms) -End (* Invariant: *) -(* -``\s. (@n. run_to_ls_m m ({l} UNION le) ms n = SOME s) + - (@n. run_to_ls_m m ({l} UNION le) s n = SOME ms') = n_l`` -*) +(* TODO: Is SING useful enough or do we need LEAST? *) +val invariant = ``\s. (SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME s)) /\ invariant s``; + (* Variant: *) -(* -``\s. (@n. run_to_ls_m m ({l} UNION le) s n = SOME ms')`` -*) +(* TODO: Make different solution so that THE can be removed... *) +val variant = ``\s. THE (ominus (SOME n_l) ($OLEAST (\n. weak_exec_n m ms ({l} UNION le) n = SOME s)))``; Theorem weak_partial_loop_rule_thm: !m. @@ -1084,179 +984,121 @@ Theorem weak_partial_loop_rule_thm: abstract_partial_jgmt m l le (\ms. invariant ms /\ ~(C1 ms)) post ==> abstract_partial_jgmt m l le invariant post Proof -(* Version with trs_n invariant: rpt strip_tac >> -SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +simp [abstract_partial_jgmt_def] >> rpt strip_tac >> fs [weak_partial_loop_contract_def] >> -subgoal `?ms''. m.weak ms ({l} UNION le) ms''` >- ( - (* There is at least ms', possibly another state if l is encountered before *) - metis_tac [weak_superset_thm, pred_setTheory.UNION_COMM] -) >> -Cases_on `m.pc ms'' IN le` >- ( - (* If le was reached without encountering l, we win immediately *) - fs [abstract_partial_jgmt_def] >> - res_tac >> - Cases_on `~C1 ms` >> ( - metis_tac [] - ) -) >> -subgoal `m.pc ms'' = l` >- ( - imp_res_tac weak_pc_in_thm >> - gs [pred_setTheory.IN_UNION] -) >> -(* Needed to establish n *) -subgoal `?n. weak_rel_steps m ms le ms' n /\ n > 0` >- ( - (* Since m.weak to le connects ms and ms' by some non-zero number of transitions *) - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> - qexists_tac `n` >> - fs [weak_rel_steps_def] -) >> -(* Needed to establish n_l *) -subgoal `?n_l. trs_n_count_ls m ms ({l} UNION le) n 0 = SOME n_l` >- ( - metis_tac [loop_n_lemma_6] -) >> -subgoal `abstract_loop_jgmt m l le (\s. ?n'. FUNPOW_OPT m.trs n' ms = SOME s /\ oadd (trs_n_count_ls m ms ({l} UNION le) n' 0) (trs_n_count_ls m s ({l} UNION le) (n-n') 0) = SOME n_l) C1 - (\s. THE (trs_to_s_count_ls m s ({l} UNION le) ms' n 0))` >- ( - cheat +(* 0. Establish n_l *) +subgoal `?n_l. (OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME ms') = SOME n_l` >- ( + ONCE_REWRITE_TAC [pred_setTheory.UNION_COMM] >> + irule weak_exec_n_exists_superset >> + fs [] ) >> -cheat -*) -rpt strip_tac >> -SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -rpt strip_tac >> -fs [weak_partial_loop_contract_def] >> -subgoal `?ms''. m.weak ms ({l} UNION le) ms''` >- ( - (* There is at least ms', possibly another state if l is encountered before *) - metis_tac [weak_superset_thm, pred_setTheory.UNION_COMM] -) >> -Cases_on `m.pc ms'' IN le` >- ( - (* If le was reached without encountering l, we win immediately *) +(* 1. Prove loop exit contract *) +subgoal `abstract_jgmt m l le (\s'. (^invariant) s' /\ ~(C1 s')) post` >- ( + fs [abstract_jgmt_def] >> + rpt strip_tac >> + subgoal `s' <> ms'` >- ( + (* Since pc of s' is l, m.weak ms le ms' and l NOTIN le *) + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + ) >> + subgoal `m.weak s' le ms'` >- ( + metis_tac [weak_inter_exec] + ) >> fs [abstract_partial_jgmt_def] >> - res_tac >> - Cases_on `~C1 ms` >> ( - metis_tac [] - ) -) >> -subgoal `m.pc ms'' = l` >- ( - imp_res_tac weak_pc_in_thm >> - gs [pred_setTheory.IN_UNION] -) >> -(* Needed to establish n *) -subgoal `?n. weak_rel_steps m ms le ms' n /\ n > 0` >- ( - (* Since m.weak to le connects ms and ms' by some non-zero number of transitions *) - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> - qexists_tac `n` >> - fs [weak_rel_steps_def] -) >> -(* Needed to establish n_l *) -subgoal `?n_l. trs_to_s_count_ls m ms ({l} UNION le) ms' n 0 = SOME n_l` >- ( - metis_tac [loop_lemma_6] + QSPECL_X_ASSUM ``!ms ms'. m.pc ms = l ==> invariant ms /\ ~C1 ms ==> m.weak ms le ms' ==> post ms'`` [`s'`, `ms'`] >> + gs [] >> + qexists_tac `ms'` >> + metis_tac [] ) >> -(* Invariant: number of l-encounters from ms to current + number of l-encounters from current to ms' - * equals n_l. - * Variant: number of encounters of l until ms' is reached *) -subgoal `abstract_loop_jgmt m l le (\s. oadd (trs_to_s_count_ls m ms ({l} UNION le) s n 0) - (trs_to_s_count_ls m s ({l} UNION le) ms' n 0) = SOME n_l /\ invariant s) C1 (\s. THE (trs_to_s_count_ls m s ({l} UNION le) ms' n 0))` >- ( + +(* 2. Prove loop iteration contract *) +subgoal `abstract_loop_jgmt m l le (^invariant) C1 (^variant)` >- ( fs [abstract_loop_jgmt_def, abstract_jgmt_def] >> rpt strip_tac >> subgoal `s <> ms'` >- ( (* Since pc of s is l, m.weak ms le ms' and l NOTIN le *) metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] ) >> - subgoal `?n_l'. trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l'` >- ( - Cases_on `trs_to_s_count_ls m ms ({l} UNION le) s n 0` >> ( - fs [oadd_def] - ) - ) >> - subgoal `?n_l''. trs_to_s_count_ls m s ({l} UNION le) ms' n 0 = SOME n_l''` >- ( - Cases_on `trs_to_s_count_ls m s ({l} UNION le) ms' n 0` >> ( - fs [oadd_def] - ) + (* n_l': the number of encounters of l up to s *) + subgoal `?n_l'. (OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME s) = SOME n_l' /\ n_l' < n_l` >- ( + metis_tac [weak_exec_sing_least_less] ) >> + (* ms''': next loop point *) subgoal `?ms'''. m.weak s ({l} UNION le) ms'''` >- ( - (* Since "?n_l. trs_to_s_count_ls m ms ({l} UNION le) s n 0 = SOME n_l" (i.e. s is somewhere between ms and ms') - * and s <> ms', weak transition from s to - * ({l} UNION le) will encounter ms' or some earlier state with pc l *) ONCE_REWRITE_TAC [pred_setTheory.UNION_COMM] >> irule weak_superset_thm >> fs [] >> qexists_tac `ms'` >> - irule weak_union2_thm >> - fs [] >> - conj_tac >| [ - metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm], - - qexists_tac `{l}` >> - metis_tac [loop_lemma_1] - ] + metis_tac [weak_inter_exec] ) >> subgoal `m.pc ms''' = l` >- ( fs [abstract_partial_jgmt_def] >> metis_tac [] ) >> qexists_tac `ms'''` >> - fs [] >> - subgoal `n_l'' > 0` >- ( - (* n_l'' must be at least one, since at the very least ms' is encountered *) - irule loop_lemma_7 >> - qexists_tac `({l} UNION le)` >> - qexists_tac `m` >> - qexists_tac `s` >> - qexists_tac `ms'` >> - qexists_tac `n` >> + subgoal `SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME ms'3')` >- ( + (* Invariant is kept *) + (* By uniqueness theorem (stating no duplicate states before ms' is reached) *) + irule weak_exec_uniqueness >> fs [] >> - metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + conj_tac >| [ + qexists_tac `SUC n_l'` >> + conj_tac >| [ + (* Since ms''' <> ms' *) + irule weak_exec_less_incr_superset >> + fs [] >> + qexistsl_tac [`{l}`, `le`, `m`, `ms`, `ms'`, `s`, `ms'''`] >> + fs [] >> + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm], + + metis_tac [weak_exec_incr] + ], + + metis_tac [] + ] ) >> + fs [] >> rpt strip_tac >| [ - (* The calls to trs_to_s_count_ls must return one greater and one lesser, respectively, preserving the equality. *) - imp_res_tac loop_lemma_2 >> - imp_res_tac loop_lemma_3 >> - fs [oadd_def], - (* By the contract for the looping case *) fs [abstract_partial_jgmt_def] >> metis_tac [], - (* Encounters of l until le will be one lesser from ms'' compared to s *) - imp_res_tac loop_lemma_3 >> - fs [] - ] -) >> -subgoal `abstract_jgmt m l le (\s'. (\s. oadd (trs_to_s_count_ls m ms ({l} UNION le) s n 0) - (trs_to_s_count_ls m s ({l} UNION le) ms' n 0) = SOME n_l /\ invariant s) s' /\ ~(C1 s')) post` >- ( - fs [abstract_jgmt_def] >> - rpt strip_tac >> - subgoal `s' <> ms'` >- ( - (* Since pc of s' is l, m.weak ms le ms' and l NOTIN le *) - metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] - ) >> - subgoal `m.weak s' le ms'` >- ( - (* s' is reached from ms by between zero and n (exclusive) transitions: - * this means that we must be able to continue transitions until ms', without encountering - * le before *) - subgoal `?n_l'. trs_to_s_count_ls m ms ({l} UNION le) s' n 0 = SOME n_l'` >- ( - Cases_on `trs_to_s_count_ls m ms ({l} UNION le) s' n 0` >> ( - fs [oadd_def] - ) + (* By arithmetic *) + subgoal `(OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME ms'3') = SOME (SUC n_l')` >- ( + metis_tac [weak_exec_incr_least] ) >> - metis_tac [loop_lemma_4] - ) >> - fs [abstract_partial_jgmt_def] >> - QSPECL_X_ASSUM ``!ms ms'. m.pc ms = l ==> invariant ms /\ ~C1 ms ==> m.weak ms le ms' ==> post ms'`` [`s'`, `ms'`] >> - gs [] >> - qexists_tac `ms'` >> - metis_tac [] + fs [ominus_def] + ] ) >> + imp_res_tac abstract_loop_rule_thm >> fs [abstract_jgmt_def] >> (* TODO: Should be provable using trs_to_ls m ({l} UNION le) ms n (SUC n_l) = SOME ms' *) QSPECL_X_ASSUM ``!s. m.pc s = l ==> _`` [`ms`] >> -subgoal `trs_to_s_count_ls m ms ({l} UNION le) ms n 0 = SOME 0` >- ( - fs [loop_lemma_5] +subgoal `SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME ms)` >- ( + subgoal `weak_exec_n m ms ({l} UNION le) 0 = SOME ms` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_def] + ) >> + subgoal `n_l > 0` >- ( + subgoal `ms <> ms'` >- ( + (* Since pc of ms is l, m.weak ms le ms' and l NOTIN le *) + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + ) >> + metis_tac [weak_exec_least_nonzero] + ) >> + (* By uniqueness theorem (stating no duplicate states before ms' is reached) *) + irule weak_exec_uniqueness >> + fs [] >> + conj_tac >| [ + qexists_tac `0` >> + fs [], + + metis_tac [] + ] ) >> -gs [oadd_def] >> +gs [] >> metis_tac [weak_unique_thm] QED From 3a374e45d1a31a27a91d50dca38721626caef1a6 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 26 May 2022 22:54:00 +0200 Subject: [PATCH 0106/1015] More cheats fixed in abstract_hoare_logic_partialScript --- .../abstract_hoare_logic_partialScript.sml | 226 ++++++++++++++---- 1 file changed, 185 insertions(+), 41 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 12e04f579..fe9470148 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -60,6 +60,7 @@ Proof fs [weak_rel_steps_def] QED +(* TODO: Contains cheats *) Theorem weak_rel_steps_to_FUNPOW_OPT_LIST: !m ms ls ms' n. weak_model m ==> @@ -115,6 +116,7 @@ QED * then there has to exist an ms'' and a *smallest* n' such that the label of * ms'' is in ls. *) (* TODO: Lemmatize further *) +(* TODO: Contains cheats *) Theorem weak_rel_steps_smallest_exists: !m. weak_model m ==> @@ -749,7 +751,47 @@ Theorem weak_superset_thm: m.weak ms ls1 ms' ==> ?ms''. m.weak ms (ls1 UNION ls2) ms'' Proof -cheat +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +Cases_on `(OLEAST n'. ?ms''. n' > 0 /\ n' < n /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' IN ls2)` >- ( + fs [] >> + qexistsl_tac [`ms'`, `n`] >> + fs [] >> + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_NONE] >> + metis_tac [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +qexistsl_tac [`ms''`, `x`] >> +fs [] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> +gs [] >> +QSPECL_X_ASSUM ``!n'. + n' < x ==> + !ms'4'. + FUNPOW_OPT m.trs n' ms = SOME ms'4' ==> + ~(n' > 0) \/ m.pc ms'4' NOTIN ls2`` [`n''`] >> +gs [] +QED + +Theorem weak_nonempty: + !m. + weak_model m ==> + !ms ls. + m.weak ms ls <> {} <=> (?ms'. m.weak ms ls ms') +Proof +rpt strip_tac >> +fs [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> +eq_tac >> (rpt strip_tac) >| [ + qexists_tac `x` >> + fs [pred_setTheory.IN_APP], + + qexists_tac `ms'` >> + fs [pred_setTheory.IN_APP] +] QED Definition ominus_def: @@ -772,21 +814,69 @@ Definition weak_exec_n_def: (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) End -(* TODO: Can prove equivalence here? *) +Definition count_ls_def: + (count_ls m ms ls 0 n_l = SOME n_l) /\ + (count_ls m ms ls (SUC n) n_l = + case m.trs ms of + | SOME ms' => + if m.pc ms' IN ls + then count_ls m ms ls n (SUC n_l) + else count_ls m ms ls n n_l + | NONE => NONE) +End + Theorem weak_exec_exists: !m. weak_model m ==> !ms ls ms'. - m.weak ms ls ms' ==> + m.weak ms ls ms' <=> weak_exec m ls ms = SOME ms' Proof rpt strip_tac >> fs [weak_exec_def] >> -subgoal `m.weak ms ls = {ms'}` >- ( - fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> - metis_tac [weak_unique_thm] +eq_tac >> ( + strip_tac +) >| [ + subgoal `m.weak ms ls = {ms'}` >- ( + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> + metis_tac [weak_unique_thm] + ) >> + fs [], + + metis_tac [pred_setTheory.CHOICE_DEF, pred_setTheory.IN_APP] +] +QED + +Theorem weak_exec_to_n: + !m. + weak_model m ==> + !ms ls ms'. + weak_exec m ls ms = SOME ms' <=> + weak_exec_n m ms ls 1 = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_n_def, FUNPOW_OPT_def] +QED + +(* TODO: Generalise this *) +(* TODO: Needs a function to count number of ls2-encounters *) +Theorem weak_exec_1_superset: + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + weak_exec_n m ms ls1 1 = SOME ms' ==> + ls1 SUBSET ls2 ==> + ?n. n >= 1 /\ (OLEAST n. weak_exec_n m ms ls2 n = SOME ms') = SOME n +Proof +(* TODO *) +rpt strip_tac >> +subgoal `?n. (OLEAST n. FUNPOW_OPT m.trs n ms = SOME ms') = SOME n` >- ( + cheat ) >> -fs [] +subgoal `?n. (OLEAST n. FUNPOW_OPT m.trs n ms = SOME ms') = SOME n` >- ( + cheat +) >> +cheat QED (* TODO: Strengthen conclusion to state either ms'' is ms', or pc is in ls2? *) @@ -798,9 +888,8 @@ Theorem weak_exec_exists_superset: ?ms''. weak_exec m (ls1 UNION ls2) ms = SOME ms'' Proof rpt strip_tac >> -fs [weak_exec_def] >> -(* OK: Either ms' is the result, or some other state with pc in ls2 was encountered before that *) -cheat +fs [weak_exec_def, weak_nonempty] >> +metis_tac [weak_superset_thm] QED Theorem weak_exec_n_exists_superset: @@ -811,10 +900,16 @@ Theorem weak_exec_n_exists_superset: ?n. (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n Proof rpt strip_tac >> -(* OK: weak_exec_n is repeated applications of weak_exec. For every such application, - * either ms' was encountered, or ls2, in which case some further number of steps - * will encounter ms'. *) -cheat +fs [whileTheory.OLEAST_EQ_SOME] >> +subgoal `weak_exec_n m ms ls1 1 = SOME ms'` >- ( + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) +) >> +imp_res_tac weak_exec_1_superset >> +QSPECL_X_ASSUM ``!ls2. _`` [`ls1 UNION ls2`] >> +fs [] >> +qexists_tac `n` >> +fs [whileTheory.OLEAST_EQ_SOME] QED Theorem weak_exec_least_nonzero: @@ -826,11 +921,10 @@ Theorem weak_exec_least_nonzero: n_l > 0 Proof rpt strip_tac >> -Cases_on `weak_exec_n m ms ls 0 = SOME ms'` >- ( - fs [weak_exec_n_def, FUNPOW_OPT_def] +Cases_on `n_l` >> ( + fs [] ) >> -(* TODO: Should be trivial: P 0 = F ==> (OLEAST n. P n) = SOME n_l ==> n_l > 0 *) -cheat +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def, FUNPOW_OPT_def] QED Theorem weak_exec_sing_least_less: @@ -841,10 +935,34 @@ Theorem weak_exec_sing_least_less: ?n_l'. (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' /\ n_l' < n_l Proof rpt strip_tac >> -(* OK: If ms' is uniquely encountered before n_l loop iterations, then - * there must be a least number of loop iterations such that ms' is - * encountered, and this number is less than n_l *) -cheat +fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +qexists_tac `x` >> +rpt strip_tac >> ( + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] +) >> +QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms' ==> x = y`` [`n`] >> +gs [] +QED + +(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' + * Let this rely on sub-lemma for incrementing weak_exec_n instead + * of reasoning on FUNPOW_OPT *) +Theorem weak_exec_incr: + !m. + weak_model m ==> + !ms ls ms' n_l ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + m.weak ms' ls ms'' ==> + weak_exec_n m ms ls (SUC n_l) = SOME ms'' +Proof +rpt strip_tac >> +simp [weak_exec_n_def, arithmeticTheory.ADD1] >> +ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> +irule FUNPOW_OPT_ADD_thm >> +qexists_tac `ms'` >> +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> +simp [FUNPOW_OPT_def] >> +metis_tac [weak_exec_exists] QED Theorem weak_inter_exec: @@ -857,6 +975,10 @@ Theorem weak_inter_exec: m.weak s' le ms' Proof rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> +fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +(* TODO: Might need something like weak_intermediate_labels2 *) (* OK: s' is a uniquely encountered (before n_l loop iterations) state, * where n_l is the least amount of applications of weak_exec to ({l} UNION le) * needed to exit the loop, @@ -864,27 +986,13 @@ rpt strip_tac >> cheat QED -(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) -Theorem weak_exec_incr: - !m. - weak_model m ==> - !ms ls ms' n_l ms''. - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> - m.weak ms' ls ms'' ==> - weak_exec_n m ms ls (SUC n_l) = SOME ms'' -Proof -rpt strip_tac >> -(* OK: ms'' reached by taking an additional weak transition from ms', - * itself reached in n_l weak transitions, can also be reached by taking - * n_l + 1 weak transitions *) -cheat -QED - (* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) Theorem weak_exec_incr_least: !m. weak_model m ==> - !ms ls ms' n_l n_l' ms''. + !ms ls ms' ms_e n_l n_l' ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms_e) = SOME n_l ==> + ms'' <> ms_e ==> (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' ==> m.weak ms' ls ms'' ==> SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms'') ==> @@ -892,12 +1000,28 @@ Theorem weak_exec_incr_least: (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME (SUC n_l') Proof rpt strip_tac >> +imp_res_tac weak_exec_incr >> +fs [whileTheory.OLEAST_EQ_SOME] >> +rpt strip_tac >> +subgoal `SUC n_l' < n_l` >- ( + Cases_on `SUC n_l' = n_l` >- ( + fs [] + ) >> + fs [] +) >> +fs [pred_setTheory.SING_DEF] >> +fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +QSPECL_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms'' ==> x = y`` [`SUC n_l'`] >> +QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms'' ==> x = y`` [`n`] >> +gs [] +(* Due to SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms''), + * both weak_exec_n m ms ls (SUC n_l') and weak_exec_n m ms ls n + * can't lead to ms''. NOTE: Requires SUC n_l' < n_l *) (* OK: If ms' was first encountered at n_l' weak iterations to ls, and * if one additional weak transition to ls goes to ms'', then if * ms'' is uniquely encountered before n_l weak transitions to ls and n_l * is greater than n_l', then SUC n_l' must be the least number of weak transitions * needed to reach ms'' *) -cheat QED (* TODO: m.weak ms ls2 ms' redundant? *) @@ -912,6 +1036,13 @@ Theorem weak_exec_uniqueness: SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') Proof rpt strip_tac >> +fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +(* Say there were another encounter of ms'' other than that at n_l' before + * n_l. Then there could be no states other than those found in between + * after them (due to cycle). But ms' was first encountered at n_l, + * which is not in the cycle between the two ms'', so there could be + * no such cycle, and thus not two ms'' before ms'. *) + (* OK: ms'' is a state encountered before n_l loop iterations, * where n_l is the least amount of applications of weak_exec to ({l} UNION le) * needed to exit the loop, @@ -936,7 +1067,17 @@ Theorem weak_exec_less_incr_superset: m.pc ms''' NOTIN ls2 ==> SUC n_l' < n_l Proof -cheat +rpt strip_tac >> +Cases_on `SUC n_l' = n_l` >- ( + subgoal `ms''' = ms'` >- ( + subgoal `weak_exec_n m ms (ls1 UNION ls2) (SUC n_l') = SOME ms'''` >- ( + metis_tac [weak_exec_incr] + ) >> + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + fs [] +) >> +fs [] QED (* @@ -1067,6 +1208,9 @@ subgoal `abstract_loop_jgmt m l le (^invariant) C1 (^variant)` >- ( (* By arithmetic *) subgoal `(OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME ms'3') = SOME (SUC n_l')` >- ( + subgoal `ms''' <> ms'` >- ( + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + ) >> metis_tac [weak_exec_incr_least] ) >> fs [ominus_def] From e305b475902025fade4f92a2c9c828c4c6be3858 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 27 May 2022 08:43:23 +0200 Subject: [PATCH 0107/1015] Fixes for partial correctness Seq theorem --- .../abstract_hoare_logic_partialScript.sml | 215 ++++++++++++++---- 1 file changed, 165 insertions(+), 50 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index fe9470148..8d81bf34c 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -642,6 +642,52 @@ Proof fs [abstract_jgmt_imp_partial_triple] QED +Theorem weak_superset_thm: + !m. + weak_model m ==> + !ms ms' ls1 ls2. + m.weak ms ls1 ms' ==> + ?ms''. m.weak ms (ls1 UNION ls2) ms'' +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +Cases_on `(OLEAST n'. ?ms''. n' > 0 /\ n' < n /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' IN ls2)` >- ( + fs [] >> + qexistsl_tac [`ms'`, `n`] >> + fs [] >> + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_NONE] >> + metis_tac [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +qexistsl_tac [`ms''`, `x`] >> +fs [] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> +gs [] >> +QSPECL_X_ASSUM ``!n'. + n' < x ==> + !ms'4'. + FUNPOW_OPT m.trs n' ms = SOME ms'4' ==> + ~(n' > 0) \/ m.pc ms'4' NOTIN ls2`` [`n''`] >> +gs [] +QED + +Theorem weak_inter: + !m. + weak_model m ==> + !ms ms' ms'' ls1 ls2. + m.weak ms (ls1 UNION ls2) ms'' ==> + m.weak ms ls2 ms' ==> + m.pc ms'' IN ls1 ==> + m.weak ms'' ls2 ms' +Proof +(* TODO *) +cheat +QED + Theorem weak_partial_seq_rule_thm: !m l ls1 ls2 pre post. weak_model m ==> @@ -655,26 +701,35 @@ SIMP_TAC std_ss [abstract_partial_jgmt_def] >> rpt strip_tac >> subgoal `?ms'. m.weak ms (ls1 UNION ls2) ms'` >- ( (* There is at least ms', possibly another state if ls1 is encountered before *) - cheat + metis_tac [weak_superset_thm, pred_setTheory.UNION_COMM] ) >> Cases_on `m.pc ms'' IN ls2` >- ( (* If ls2 was reached without encountering ls1, we win immediately *) - cheat + imp_res_tac weak_union2_thm >> + subgoal `ms' = ms''` >- ( + metis_tac [weak_unique_thm] + ) >> + metis_tac [abstract_partial_jgmt_def] ) >> subgoal `m.pc ms'' IN ls1` >- ( - (* Set theory *) - cheat + imp_res_tac weak_union_pc_not_in_thm >> + metis_tac [weak_pc_in_thm] ) >> subgoal `?l1. m.pc ms'' = l1` >- ( (* Technically requires ls1 non-empty, but if that is the case, we also win immediately *) - cheat + metis_tac [] +) >> +subgoal `?ls1'. ls1 UNION ls2 = ls1' UNION ls2 /\ DISJOINT ls1' ls2` >- ( + qexists_tac `ls1 DIFF ls2` >> + fs [pred_setTheory.DISJOINT_DIFF] ) >> -subgoal `abstract_jgmt m l (ls1 UNION ls2) (\s. s = ms /\ pre s) (\s. (m.pc s IN ls1 ==> s = ms'') /\ (m.pc s IN ls2 ==> post s))` >- ( +fs [] >> +subgoal `abstract_jgmt m l (ls1' UNION ls2) (\s. s = ms /\ pre s) (\s. (m.pc s IN ls1' ==> s = ms'') /\ (m.pc s IN ls2 ==> post s))` >- ( fs [abstract_jgmt_def, abstract_partial_jgmt_def] >> qexists_tac ‘ms''’ >> fs [] ) >> -subgoal `!l1'. (l1' IN ls1) ==> (abstract_jgmt m l1' ls2 (\s. (m.pc s IN ls1 ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)) (\s. (m.pc s IN ls1 ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)))` >- ( +subgoal `!l1'. (l1' IN ls1') ==> (abstract_jgmt m l1' ls2 (\s. (m.pc s IN ls1' ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)) (\s. (m.pc s IN ls1' ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)))` >- ( rpt strip_tac >> fs [abstract_jgmt_def, abstract_partial_jgmt_def] >> rpt strip_tac >> @@ -686,12 +741,11 @@ subgoal `!l1'. (l1' IN ls1) ==> (abstract_jgmt m l1' ls2 (\s. (m.pc s IN ls1 ==> fs [] >> subgoal `m.weak ms'' ls2 ms'` >- ( (* Since ms'' is a ls1-point encountered between ms and ls2 *) - cheat + metis_tac [weak_inter] ) >> qexists_tac ‘ms'’ >> fs [] >> - (* OK: ms'3' is not in ls1 (weak_pc_in_thm) *) - cheat + metis_tac [weak_pc_in_thm, pred_setTheory.IN_DISJOINT] ) >> imp_res_tac abstract_seq_rule_thm >> gs [abstract_jgmt_def] >> @@ -744,39 +798,6 @@ Definition weak_partial_loop_contract_def: (\ms. m.pc ms = l /\ invariant ms)) End -Theorem weak_superset_thm: - !m. - weak_model m ==> - !ms ms' ls1 ls2. - m.weak ms ls1 ms' ==> - ?ms''. m.weak ms (ls1 UNION ls2) ms'' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -Cases_on `(OLEAST n'. ?ms''. n' > 0 /\ n' < n /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' IN ls2)` >- ( - fs [] >> - qexistsl_tac [`ms'`, `n`] >> - fs [] >> - rpt strip_tac >> - fs [whileTheory.OLEAST_EQ_NONE] >> - metis_tac [] -) >> -fs [whileTheory.OLEAST_EQ_SOME] >> -qexistsl_tac [`ms''`, `x`] >> -fs [] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> -gs [] >> -QSPECL_X_ASSUM ``!n'. - n' < x ==> - !ms'4'. - FUNPOW_OPT m.trs n' ms = SOME ms'4' ==> - ~(n' > 0) \/ m.pc ms'4' NOTIN ls2`` [`n''`] >> -gs [] -QED - Theorem weak_nonempty: !m. weak_model m ==> @@ -858,8 +879,74 @@ rpt strip_tac >> fs [weak_exec_n_def, FUNPOW_OPT_def] QED +(* +Theorem count_ls_step: + !m. + weak_model m ==> + !ms ls n n_l. + count_ls m ms ls (SUC n) 0 = SOME n_l ==> + ?n_l' n_l''. count_ls m ms ls n 0 = SOME n_l' /\ + count_ls m ms ls 1 n_l' = SOME n_l'' /\ n_l = n_l' + n_l'' +Proof +(* TODO *) +cheat +QED +*) + +(* If ms' is reached from ms in n steps, and if n_l encounters + * of ls were counted during those n steps, then n_l weak + * transitions to ls are needed to get from ms to ms' *) +Theorem weak_exec_n_count: + !m. + weak_model m ==> + !ms ls n n_l ms'. + (OLEAST n. n > 0 /\ FUNPOW_OPT m.trs n ms = SOME ms') = SOME n ==> + count_ls m ms ls n 0 = SOME n_l ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l +Proof +(* TODO *) +rpt strip_tac >> +cheat +QED + +Theorem count_ls_some: + !m. + weak_model m ==> + !ms ls n. + (?ms'. FUNPOW_OPT m.trs n ms = SOME ms') ==> + ?n_l. count_ls m ms ls n 0 = SOME n_l +Proof +(* TODO *) +ntac 4 strip_tac >> +Induct_on `n` >- ( + cheat +) >> +rpt strip_tac >> +subgoal `?ms'. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( + irule FUNPOW_OPT_prev_EXISTS >> + qexists_tac `SUC n` >> + qexists_tac `ms'` >> + fs [] +) >> +fs [] +(* Should be OK *) +cheat +QED + +Theorem count_ls_final: + !m. + weak_model m ==> + !ms ls n n_l. + (?ms'. FUNPOW_OPT m.trs n ms = SOME ms' /\ m.pc ms' IN ls) ==> + count_ls m ms ls n 0 = SOME n_l ==> + n_l >= 1 +Proof +(* TODO *) +(* Split up both FUNPOW_OPT and count_ls into last step and all previous? *) +cheat +QED + (* TODO: Generalise this *) -(* TODO: Needs a function to count number of ls2-encounters *) Theorem weak_exec_1_superset: !m. weak_model m ==> @@ -868,15 +955,37 @@ Theorem weak_exec_1_superset: ls1 SUBSET ls2 ==> ?n. n >= 1 /\ (OLEAST n. weak_exec_n m ms ls2 n = SOME ms') = SOME n Proof -(* TODO *) rpt strip_tac >> -subgoal `?n. (OLEAST n. FUNPOW_OPT m.trs n ms = SOME ms') = SOME n` >- ( - cheat +fs [weak_exec_n_def, FUNPOW_OPT_compute] >> +Cases_on `weak_exec m ls1 ms` >> ( + fs [] ) >> -subgoal `?n. (OLEAST n. FUNPOW_OPT m.trs n ms = SOME ms') = SOME n` >- ( - cheat +rw [] >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +subgoal `(OLEAST n. n > 0 /\ FUNPOW_OPT m.trs n ms = SOME ms') = SOME n` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + rpt strip_tac >> + QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> + gs [] ) >> -cheat +subgoal `?n_l. count_ls m ms ls2 n 0 = SOME n_l` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + gs [count_ls_some] +) >> +subgoal `n_l >= 1` >- ( + subgoal `m.pc ms' IN ls1` >- ( + fs [] + ) >> + subgoal `m.pc ms' IN ls2` >- ( + metis_tac [pred_setTheory.SUBSET_THM] + ) >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [count_ls_final] +) >> +qexists_tac `n_l` >> +gs [GSYM weak_exec_n_def] >> +metis_tac [weak_exec_n_count] QED (* TODO: Strengthen conclusion to state either ms'' is ms', or pc is in ls2? *) @@ -975,9 +1084,15 @@ Theorem weak_inter_exec: m.weak s' le ms' Proof rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +(* There is a number of trs X that goes from ms to ms'. + * There is also a strictly smaller (since x < n_l) number of trs Y that goes from ms to s'. + * ms' was the first state in le that was encountered by definition of weak, so performing a weak + * transition from s' (at Y steps) will always end up at ms'. *) + (* TODO: Might need something like weak_intermediate_labels2 *) (* OK: s' is a uniquely encountered (before n_l loop iterations) state, * where n_l is the least amount of applications of weak_exec to ({l} UNION le) From a8dda86d76df67d51577042251cedf9712688dd2 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 27 May 2022 08:47:31 +0200 Subject: [PATCH 0108/1015] Typo --- .../abstract_hoare_logic/abstract_hoare_logic_partialScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 8d81bf34c..8208480b1 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -928,7 +928,7 @@ subgoal `?ms'. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( qexists_tac `ms'` >> fs [] ) >> -fs [] +fs [] >> (* Should be OK *) cheat QED From d58994c4beb0f4d5fb6a1246e877c40b466c5467 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Fri, 27 May 2022 09:53:19 +0200 Subject: [PATCH 0109/1015] Another fix to Seq proof --- .../abstract_hoare_logic_partialScript.sml | 240 +++++++++--------- 1 file changed, 125 insertions(+), 115 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 8208480b1..c9dc6720f 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -21,6 +21,37 @@ Definition weak_rel_steps_def: )) End +Definition ominus_def: + (ominus NONE _ = NONE) /\ + (ominus _ NONE = NONE) /\ + (ominus (SOME (n:num)) (SOME n') = SOME (n - n')) +End + +Definition weak_exec_def: + (weak_exec m ls ms = + let + MS' = m.weak ms ls + in + if MS' = {} + then NONE + else SOME (CHOICE MS')) +End + +Definition weak_exec_n_def: + (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) +End + +Definition count_ls_def: + (count_ls m ms ls 0 n_l = SOME n_l) /\ + (count_ls m ms ls (SUC n) n_l = + case m.trs ms of + | SOME ms' => + if m.pc ms' IN ls + then count_ls m ms ls n (SUC n_l) + else count_ls m ms ls n n_l + | NONE => NONE) +End + Theorem weak_rel_steps_imp: !m ms ls ms' n. weak_model m ==> @@ -675,17 +706,108 @@ QSPECL_X_ASSUM ``!n'. gs [] QED +Theorem weak_nonempty: + !m. + weak_model m ==> + !ms ls. + m.weak ms ls <> {} <=> (?ms'. m.weak ms ls ms') +Proof +rpt strip_tac >> +fs [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> +eq_tac >> (rpt strip_tac) >| [ + qexists_tac `x` >> + fs [pred_setTheory.IN_APP], + + qexists_tac `ms'` >> + fs [pred_setTheory.IN_APP] +] +QED + +Theorem weak_exec_exists: + !m. + weak_model m ==> + !ms ls ms'. + m.weak ms ls ms' <=> + weak_exec m ls ms = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_def] >> +eq_tac >> ( + strip_tac +) >| [ + subgoal `m.weak ms ls = {ms'}` >- ( + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> + metis_tac [weak_unique_thm] + ) >> + fs [], + + metis_tac [pred_setTheory.CHOICE_DEF, pred_setTheory.IN_APP] +] +QED + +Theorem weak_exec_to_n: + !m. + weak_model m ==> + !ms ls ms'. + weak_exec m ls ms = SOME ms' <=> + weak_exec_n m ms ls 1 = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_n_def, FUNPOW_OPT_def] +QED + Theorem weak_inter: !m. weak_model m ==> !ms ms' ms'' ls1 ls2. - m.weak ms (ls1 UNION ls2) ms'' ==> + DISJOINT ls1 ls2 ==> m.weak ms ls2 ms' ==> + m.weak ms (ls1 UNION ls2) ms'' ==> m.pc ms'' IN ls1 ==> m.weak ms'' ls2 ms' Proof -(* TODO *) -cheat +rpt strip_tac >> +(* ms goes to ms' in n steps. ms goes to ms'' in n' steps, for which: + * n'>n: impossible, by the first-encounter property + * n=n': impossible, since ms' is in ls2 and ms'' is in ls1 (disjoint sets) + * n' fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +subgoal `~(n'>n)` >- ( + QSPECL_X_ASSUM ``!n''. + n'' < n' /\ n'' > 0 ==> + ?ms'3'. + FUNPOW_OPT m.trs n'' ms = SOME ms'3' /\ m.pc ms'3' NOTIN ls1 /\ + m.pc ms'3' NOTIN ls2`` [`n`] >> + gs [] +) >> +subgoal `~(n'=n)` >- ( + strip_tac >> + gs [] >> + metis_tac [pred_setTheory.IN_DISJOINT] +) >> +subgoal `n'- ( + fs [] +) >> +qexists_tac `n-n'` >> +rpt strip_tac >| [ + fs [], + + (* by combining execution *) + irule FUNPOW_OPT_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [], + + (* non-encounter in earlier steps *) + QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n' + n''`] >> + gs [] >> + qexists_tac `ms'''` >> + fs [] >> + metis_tac [FUNPOW_OPT_INTER, arithmeticTheory.ADD_COMM] +] QED Theorem weak_partial_seq_rule_thm: @@ -758,37 +880,6 @@ subgoal `m.pc ms' IN ls2` >- ( metis_tac [weak_pc_in_thm] ) >> metis_tac [] - - -(* OLD, working proof: *) -(* -rpt strip_tac >> -FULL_SIMP_TAC std_ss [abstract_partial_jgmt_def] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!ms ms'. - (m.pc ms = l) ==> - pre ms ==> - m.weak ms (ls1 UNION ls2) ms' ==> - post ms'`` [`ms`] >> -rfs [] >> -subgoal `(m.pc ms') IN ls2` >- ( - metis_tac [weak_pc_in_thm] -) >> -Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( - metis_tac [] -) >> -subgoal `?ms''. m.pc ms'' IN ls1 /\ m.weak ms (ls2 UNION ls1) ms''` >- ( - metis_tac [weak_intermediate_labels, pred_setTheory.UNION_COMM] -) >> -QSPECL_X_ASSUM ``!l1. l1 IN ls1 ==> _`` [`m.pc ms''`] >> -rfs [] >> -QSPECL_X_ASSUM ``!ms ms'. _`` [`ms''`, `ms'`] >> -rfs [] >> -subgoal `post ms''` >- ( - metis_tac [pred_setTheory.UNION_COMM] -) >> -metis_tac [pred_setTheory.UNION_COMM, weak_intermediate_labels2] -*) QED Definition weak_partial_loop_contract_def: @@ -798,87 +889,6 @@ Definition weak_partial_loop_contract_def: (\ms. m.pc ms = l /\ invariant ms)) End -Theorem weak_nonempty: - !m. - weak_model m ==> - !ms ls. - m.weak ms ls <> {} <=> (?ms'. m.weak ms ls ms') -Proof -rpt strip_tac >> -fs [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> -eq_tac >> (rpt strip_tac) >| [ - qexists_tac `x` >> - fs [pred_setTheory.IN_APP], - - qexists_tac `ms'` >> - fs [pred_setTheory.IN_APP] -] -QED - -Definition ominus_def: - (ominus NONE _ = NONE) /\ - (ominus _ NONE = NONE) /\ - (ominus (SOME (n:num)) (SOME n') = SOME (n - n')) -End - -Definition weak_exec_def: - (weak_exec m ls ms = - let - MS' = m.weak ms ls - in - if MS' = {} - then NONE - else SOME (CHOICE MS')) -End - -Definition weak_exec_n_def: - (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) -End - -Definition count_ls_def: - (count_ls m ms ls 0 n_l = SOME n_l) /\ - (count_ls m ms ls (SUC n) n_l = - case m.trs ms of - | SOME ms' => - if m.pc ms' IN ls - then count_ls m ms ls n (SUC n_l) - else count_ls m ms ls n n_l - | NONE => NONE) -End - -Theorem weak_exec_exists: - !m. - weak_model m ==> - !ms ls ms'. - m.weak ms ls ms' <=> - weak_exec m ls ms = SOME ms' -Proof -rpt strip_tac >> -fs [weak_exec_def] >> -eq_tac >> ( - strip_tac -) >| [ - subgoal `m.weak ms ls = {ms'}` >- ( - fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> - metis_tac [weak_unique_thm] - ) >> - fs [], - - metis_tac [pred_setTheory.CHOICE_DEF, pred_setTheory.IN_APP] -] -QED - -Theorem weak_exec_to_n: - !m. - weak_model m ==> - !ms ls ms'. - weak_exec m ls ms = SOME ms' <=> - weak_exec_n m ms ls 1 = SOME ms' -Proof -rpt strip_tac >> -fs [weak_exec_n_def, FUNPOW_OPT_def] -QED - (* Theorem count_ls_step: !m. From 45cc6413cffb68dbc3d4c73ad68884777a22740d Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Sun, 29 May 2022 02:50:26 +0200 Subject: [PATCH 0110/1015] Fixed more cheats in abstract_hoare_logic_partialScript --- .../abstract_hoare_logic_auxScript.sml | 12 - .../abstract_hoare_logic_partialScript.sml | 711 +++++++++++++++--- 2 files changed, 587 insertions(+), 136 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index 8362925ce..e15a39c8c 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -426,18 +426,6 @@ Proof fs [GSYM arithmeticTheory.FUNPOW_ADD] QED -(* -(* TODO: Same as FUNPOW_OPT_INTER with commutativity of addition *) -val FUNPOW_OPT_split = prove(`` -!f n n' s s' s''. -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f (n + n') s = SOME s'' ==> -FUNPOW_OPT f n' s' = SOME s''``, - -metis_tac [FUNPOW_ASSOC, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] -); -*) - Theorem FUNPOW_OPT_split2: !f n' n s s'' s'. n > n' ==> diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index c9dc6720f..6bee5a356 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -8,6 +8,7 @@ open abstract_hoare_logic_auxTheory abstract_hoare_logicTheory; val _ = new_theory "abstract_hoare_logic_partial"; +(* TODO: Do away with this and everything related to it? *) Definition weak_rel_steps_def: weak_rel_steps m ms ls ms' n = ((n > 0 /\ @@ -41,16 +42,18 @@ Definition weak_exec_n_def: (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) End -Definition count_ls_def: - (count_ls m ms ls 0 n_l = SOME n_l) /\ - (count_ls m ms ls (SUC n) n_l = - case m.trs ms of - | SOME ms' => - if m.pc ms' IN ls - then count_ls m ms ls n (SUC n_l) - else count_ls m ms ls n n_l - | NONE => NONE) -End +Theorem FUNPOW_OPT_split: +!f n' n s s'' s'. +n > n' ==> +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f (n - n') s = SOME s'' ==> +FUNPOW_OPT f n' s'' = SOME s' +Proof +rpt strip_tac >> +irule FUNPOW_OPT_INTER >> +qexistsl_tac [`s`, `n - n'`] >> +fs [] +QED Theorem weak_rel_steps_imp: !m ms ls ms' n. @@ -889,113 +892,602 @@ Definition weak_partial_loop_contract_def: (\ms. m.pc ms = l /\ invariant ms)) End -(* -Theorem count_ls_step: +Theorem weak_least_trs: + !m ms ls ms'. + weak_model m ==> + ms <> ms' ==> + m.weak ms ls ms' ==> + ?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' ms = SOME ms') = SOME n' +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +qexists_tac `n` >> +fs [whileTheory.OLEAST_EQ_SOME] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> +gs [] >> +subgoal `n' = 0` >- ( + fs [] +) >> +rw [] >> +gs [FUNPOW_OPT_compute] +QED + +(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' + * Let this rely on sub-lemma for incrementing weak_exec_n instead + * of reasoning on FUNPOW_OPT *) +Theorem weak_exec_incr_last: !m. weak_model m ==> - !ms ls n n_l. - count_ls m ms ls (SUC n) 0 = SOME n_l ==> - ?n_l' n_l''. count_ls m ms ls n 0 = SOME n_l' /\ - count_ls m ms ls 1 n_l' = SOME n_l'' /\ n_l = n_l' + n_l'' + !ms ls ms' n_l ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + m.weak ms' ls ms'' ==> + weak_exec_n m ms ls (SUC n_l) = SOME ms'' Proof -(* TODO *) -cheat +rpt strip_tac >> +simp [weak_exec_n_def, arithmeticTheory.ADD1] >> +ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> +irule FUNPOW_OPT_ADD_thm >> +qexists_tac `ms'` >> +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> +simp [FUNPOW_OPT_def] >> +metis_tac [weak_exec_exists] QED -*) -(* If ms' is reached from ms in n steps, and if n_l encounters - * of ls were counted during those n steps, then n_l weak - * transitions to ls are needed to get from ms to ms' *) -Theorem weak_exec_n_count: +Theorem weak_exec_incr_first: !m. weak_model m ==> - !ms ls n n_l ms'. - (OLEAST n. n > 0 /\ FUNPOW_OPT m.trs n ms = SOME ms') = SOME n ==> - count_ls m ms ls n 0 = SOME n_l ==> - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l + !ms ls ms' n_l ms''. + m.weak ms ls ms' ==> + (OLEAST n. weak_exec_n m ms' ls n = SOME ms'') = SOME n_l ==> + weak_exec_n m ms ls (SUC n_l) = SOME ms'' Proof -(* TODO *) rpt strip_tac >> -cheat +simp [weak_exec_n_def, arithmeticTheory.ADD1] >> +irule FUNPOW_OPT_ADD_thm >> +qexists_tac `ms'` >> +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> +simp [FUNPOW_OPT_def] >> +metis_tac [weak_exec_exists] QED -Theorem count_ls_some: +Theorem weak_exec_n_prev: !m. weak_model m ==> - !ms ls n. - (?ms'. FUNPOW_OPT m.trs n ms = SOME ms') ==> - ?n_l. count_ls m ms ls n 0 = SOME n_l + !ms ls ms' n_l. + weak_exec_n m ms ls (SUC n_l) = SOME ms' ==> + ?ms''. weak_exec_n m ms ls n_l = SOME ms'' /\ weak_exec_n m ms'' ls 1 = SOME ms' Proof -(* TODO *) -ntac 4 strip_tac >> -Induct_on `n` >- ( - cheat -) >> rpt strip_tac >> -subgoal `?ms'. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( - irule FUNPOW_OPT_prev_EXISTS >> - qexists_tac `SUC n` >> - qexists_tac `ms'` >> +fs [weak_exec_n_def] >> +subgoal `SUC n_l > 0` >- ( fs [] ) >> +imp_res_tac FUNPOW_OPT_prev_EXISTS >> +QSPECL_X_ASSUM ``!n'. _`` [`n_l`] >> fs [] >> -(* Should be OK *) -cheat +Cases_on `n_l = 0` >- ( + gs [FUNPOW_OPT_compute] +) >> +irule FUNPOW_OPT_split >> +qexistsl_tac [`SUC n_l`, `ms`] >> +fs [arithmeticTheory.ADD1] QED -Theorem count_ls_final: +Theorem weak_union_pc: !m. weak_model m ==> - !ms ls n n_l. - (?ms'. FUNPOW_OPT m.trs n ms = SOME ms' /\ m.pc ms' IN ls) ==> - count_ls m ms ls n 0 = SOME n_l ==> - n_l >= 1 + !ms ls1 ls2 ms' ms''. + m.weak ms ls2 ms' ==> + m.weak ms (ls1 UNION ls2) ms'' ==> + ms' <> ms'' ==> + m.pc ms'' IN ls1 +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +Cases_on `n' > n` >- ( + QSPECL_X_ASSUM ``!n''. + n'' < n' /\ n'' > 0 ==> + ?ms'3'. + FUNPOW_OPT m.trs n'' ms = SOME ms'3' /\ m.pc ms'3' NOTIN ls1 /\ + m.pc ms'3' NOTIN ls2`` [`n`] >> + gs [] +) >> +Cases_on `n' = n` >- ( + gs [] +) >> +QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n'`] >> +gs [] +QED + +Theorem weak_exec_n_add: +!m. weak_model m ==> +!s s' s'' ls n n'. +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s' ls n' = SOME s'' ==> +weak_exec_n m s ls (n + n') = SOME s'' +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] +QED + +Theorem weak_exec_n_split: +!m. weak_model m ==> +!s s' s'' ls n n'. +n > n' ==> +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s ls (n - n') = SOME s'' ==> +weak_exec_n m s'' ls n' = SOME s' Proof -(* TODO *) -(* Split up both FUNPOW_OPT and count_ls into last step and all previous? *) cheat QED -(* TODO: Generalise this *) -Theorem weak_exec_1_superset: +Theorem weak_exec_n_split2: +!m. weak_model m ==> +!s s' s'' ls n n'. +n >= n' ==> +weak_exec_n m s ls n' = SOME s'' ==> +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s'' ls (n - n') = SOME s' +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +Cases_on `n = n'` >- ( + fs [FUNPOW_OPT_compute] +) >> +subgoal `n > n'` >- ( + fs [] +) >> +metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +QED + +Theorem weak_exec_n_inter: !m. weak_model m ==> - !ms ls1 ls2 ms'. - weak_exec_n m ms ls1 1 = SOME ms' ==> - ls1 SUBSET ls2 ==> - ?n. n >= 1 /\ (OLEAST n. weak_exec_n m ms ls2 n = SOME ms') = SOME n + !ms ms' ls1 ls2 n_l n_l'. + DISJOINT ls1 ls2 ==> + weak_exec_n m ms ls2 1 = SOME ms' ==> + (OLEAST n_l. weak_exec_n m ms (ls1 UNION ls2) n_l = SOME ms') = SOME n_l ==> + n_l' < n_l ==> + !ms''. + (OLEAST n_l. weak_exec_n m ms (ls1 UNION ls2) n_l = SOME ms'') = SOME n_l' ==> + weak_exec_n m ms'' ls2 1 = SOME ms' Proof +ntac 7 strip_tac >> +Induct_on `n_l'` >- ( + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def, FUNPOW_OPT_compute] +) >> rpt strip_tac >> -fs [weak_exec_n_def, FUNPOW_OPT_compute] >> -Cases_on `weak_exec m ls1 ms` >> ( - fs [] +gs [whileTheory.OLEAST_EQ_SOME] >> +imp_res_tac weak_exec_n_prev >> +QSPECL_X_ASSUM ``!ms'3'. + weak_exec_n m ms (ls1 UNION ls2) n_l' = SOME ms'3' /\ + (!n_l. + n_l < n_l' ==> + weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms'3') ==> + weak_exec_n m ms'3' ls2 1 = SOME ms'`` [`ms'''`] >> +gs [] >> +subgoal `!n_l. n_l < n_l' ==> weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms'3'` >- ( + rpt strip_tac >> + QSPECL_X_ASSUM ``!n_l. + n_l < SUC n_l' ==> + weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms''`` [`SUC n_l''`] >> + gs [] >> + metis_tac [weak_exec_n_add, arithmeticTheory.ADD1] ) >> -rw [] >> +fs [] >> +(* TODO: Build together that you can proceed one weak transition to superset from ms''', + * and from the reach ms' whith next weak transition to ls2 *) +(* See reasoning in weak_inter *) +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -subgoal `(OLEAST n. n > 0 /\ FUNPOW_OPT m.trs n ms = SOME ms') = SOME n` >- ( +irule weak_inter >> +fs [] >> +qexistsl_tac [`ls1`, `ms'''`] >> +fs [] >> +subgoal `ms' <> ms''` >- ( +QSPECL_X_ASSUM ``!n_l'. + n_l' < n_l ==> weak_exec_n m ms (ls1 UNION ls2) n_l' <> SOME ms'`` [`SUC n_l'`] >> + gs [] +) >> +metis_tac [weak_union_pc] +QED + +Theorem weak_inter_exec: + !m. + weak_model m ==> + !ms ls1 ls2 n_l ms' ms''. + m.weak ms ls2 ms' ==> + DISJOINT ls1 ls2 ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> + SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') ==> + m.weak ms'' ls2 ms' +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) >> +(* +subgoal `ms' <> ms''` >- ( + fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> + QSPECL_X_ASSUM ``!n. n < n_l ==> weak_exec_n m ms (ls1 UNION ls2) n <> SOME ms'`` [`x`] >> + gs [] +) >> +*) +irule weak_exec_n_inter >> +fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +qexistsl_tac [`ls1`, `ms`, `n_l`, `x`] >> +fs [] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms (ls1 UNION ls2) y = SOME ms'' ==> x = y`` [`n_l'`] >> +subgoal `n_l' < n_l` >- ( + gs [] +) >> +fs [] +QED + +Theorem weak_subset: + !m. weak_model m ==> + !ms ls1 ls2 ms'. + m.weak ms (ls1 UNION ls2) ms' ==> + ls1 SUBSET ls2 ==> + m.weak ms ls2 ms' +Proof +rpt strip_tac >> +fs [pred_setTheory.SUBSET_UNION_ABSORPTION] +QED + +Theorem weak_exec_n_OLEAST_equiv: + !m. weak_model m ==> + !s ls s'. + (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s') = SOME 1 ==> + m.weak s ls s' +Proof +rpt strip_tac >> +fs [whileTheory.OLEAST_EQ_SOME] >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) +QED + +(* For suffices_by in below proof +Theorem TEST_lemma: + !m. weak_model m ==> + !s s' s'' ls n_l. + s <> s' ==> + s'' <> s' ==> + n_l > 0 ==> + weak_exec_n m s ls 1 = SOME s'' ==> + weak_exec_n m s ls 1 <> SOME s' /\ (!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s') ==> + !n_l'. n_l' < n_l + 1 ==> weak_exec_n m s ls n_l' <> SOME s' +Proof +rpt strip_tac >> +fs [] >> +QSPECL_X_ASSUM ``!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'`` [`n_l' - 1`] >> +gs [] >> +subgoal `n_l' >= 1` >- ( + Cases_on `n_l' = 0` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ) >> + fs [] +) >> +metis_tac [weak_exec_n_split2] +QED +*) + +(* Continuing weak_exec_n at s'', intermediately between s and s'' *) +Theorem weak_exec_n_OLEAST_inter: + !m. weak_model m ==> + !s s' s'' ls n' n'' n_l. + (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s') = SOME n' ==> + (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' s = SOME s'') = SOME n'' ==> + n' > n'' ==> + (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s'') = SOME 1 ==> + (OLEAST n_l. weak_exec_n m s'' ls n_l = SOME s') = SOME n_l ==> + (OLEAST n_l. weak_exec_n m s ls n_l = SOME s') = SOME (n_l + 1) +Proof +rpt strip_tac >> +simp [whileTheory.OLEAST_EQ_SOME] >> +conj_tac >| [ + metis_tac [arithmeticTheory.ADD1, weak_exec_incr_first, weak_exec_n_OLEAST_equiv], + fs [whileTheory.OLEAST_EQ_SOME] >> - rpt strip_tac >> + subgoal `s <> s'` >- ( + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`0`] >> + subgoal `0 < n'` >- ( + fs [] + ) >> + gs [FUNPOW_OPT_compute] + ) >> + subgoal `s'' <> s'` >- ( + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''`] >> + gs [] + ) >> + subgoal `n_l > 0` >- ( + Cases_on `n_l = 0` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ) >> + fs [] + ) >> + `weak_exec_n m s ls 1 <> SOME s' /\ !n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'` suffices_by ( + rpt strip_tac >> + fs [] >> + QSPECL_X_ASSUM ``!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'`` [`n_l' - 1`] >> + gs [] >> + subgoal `n_l' >= 1` >- ( + Cases_on `n_l' = 0` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ) >> + fs [] + ) >> + metis_tac [weak_exec_n_split2] + ) >> + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''`] >> + gs [] +] +QED + +Theorem weak_exec_1_superset_lemma: + !m. + weak_model m ==> + !ls1 ls2 s'. + !n n'. n' <= n ==> + n' >= 1 ==> + !s. m.weak s ls1 s' /\ ((OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s') = SOME n') ==> + s <> s' ==> + ls1 SUBSET ls2 ==> + ?n_l. n_l >= 1 /\ (OLEAST n_l. weak_exec_n m s ls2 n_l = SOME s') = SOME n_l +Proof +ntac 5 strip_tac >> +Induct_on `n` >- ( + fs [] +) >> +rpt strip_tac >> +Cases_on `n' < SUC n` >- ( QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> gs [] ) >> -subgoal `?n_l. count_ls m ms ls2 n 0 = SOME n_l` >- ( +subgoal `n' = SUC n` >- ( + fs [] +) >> +Cases_on `n = 0` >- ( + gs [] >> + subgoal `n' = 1` >- ( + fs [] + ) >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `1` >> + fs [] >> + conj_tac >| [ + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + qexists_tac `1` >> + fs [] >> + metis_tac [weak_pc_in_thm, pred_setTheory.SUBSET_THM], + + rpt strip_tac >> + subgoal `n_l' = 0` >- ( + fs [] + ) >> + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ] +) >> +(* 1. There exists a state s'' which we go to with weak-ls2 from s. (weak_superset_thm should suffice) + * s'' is reached with more trs than s': contradiction. + * s'' is reached with same amount of trs as s': s'' is s', proof completed + * with witness n_l''. + * s'' is reached with fewer trs than s': use induction hypothesis specialised for s'', then add + * numbers of weak-ls2 transitions together for the witness. *) +subgoal `?s''. (OLEAST n_l''. n_l'' > 0 /\ weak_exec_n m s ls2 n_l'' = SOME s'') = SOME 1` >- ( + subgoal `?ms''. m.weak s (ls1 UNION ls2) ms''` >- ( + metis_tac [weak_superset_thm] + ) >> + qexistsl_tac [`ms''`] >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [weak_subset, weak_exec_to_n, weak_exec_exists] +) >> +subgoal `?n''. (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' s = SOME s'') = SOME n''` >- ( + (* Since s'' is reached by non-zero weak transitions, there must be a (least) non-zero number of trs + * that reaches it *) fs [whileTheory.OLEAST_EQ_SOME] >> - gs [count_ls_some] + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + qexists_tac `n'''` >> + fs [] >> + rpt strip_tac >> + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n''''`] >> + gs [] ) >> -subgoal `n_l >= 1` >- ( - subgoal `m.pc ms' IN ls1` >- ( +(* s'' is reached with more trs than s': contradiction, s' would have been crossed *) +Cases_on `n'' > n'` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + subgoal `m.weak s ls2 s''` >- ( + metis_tac [weak_exec_to_n, weak_exec_exists] + ) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + (* TODO: Make some kind of lemma here? *) + Q.SUBGOAL_THEN `n'4' = n''` (fn thm => fs [thm]) >- ( + Cases_on `n'' < n'4'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'4' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n''`] >> + gs [] + ) >> + Cases_on `n'' > n'4'` >- ( + QSPECL_X_ASSUM ``!n'3'. + n'3' < n'' ==> FUNPOW_OPT m.trs n'3' s = SOME s'' ==> ~(n'3' > 0)`` [`n''''`] >> + gs [] + ) >> fs [] ) >> - subgoal `m.pc ms' IN ls2` >- ( - metis_tac [pred_setTheory.SUBSET_THM] + (* TODO: Make some kind of lemma here? *) + Q.SUBGOAL_THEN `n'3' = n'` (fn thm => fs [thm]) >- ( + Cases_on `n' < n'3'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> + gs [] + ) >> + Cases_on `n' > n'3'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'''`] >> + gs [] + ) >> + fs [] + ) >> + QSPECL_X_ASSUM ``!n'. + n' < n'' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n'`] >> + gs [] >> + metis_tac [pred_setTheory.SUBSET_THM] +) >> +Cases_on `n'' = n'` >- ( + qexists_tac `1` >> + subgoal `s'' = s'` >- ( + fs [whileTheory.OLEAST_EQ_SOME] ) >> fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [count_ls_final] + rpt strip_tac >> + subgoal `n_l = 0` >- ( + fs [] + ) >> + fs [weak_exec_n_def, FUNPOW_OPT_compute] +) >> +subgoal `n'' < n'` >- ( + fs [] +) >> +QSPECL_X_ASSUM ``!n'. _`` [`n' - n''`] >> +rfs [] >> +subgoal `n' <= n + n''` >- ( + gs [whileTheory.OLEAST_EQ_SOME] +) >> +fs [] >> +QSPECL_X_ASSUM ``!s'''. _`` [`s''`] >> +(* Should be possible to prove with some inter theorem... *) +subgoal `m.weak s'' ls1 s'` >- ( + (* Next state in s'' is s'... *) + PAT_ASSUM ``weak_model m`` (fn thm => simp [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + qexists_tac `n' - n''` >> + fs [] >> + rpt conj_tac >| [ + irule FUNPOW_OPT_split >> + qexistsl_tac [`n'`, `s`] >> + fs [whileTheory.OLEAST_EQ_SOME], + + metis_tac [weak_pc_in_thm], + + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_SOME] >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + (* TODO: Make some kind of lemma here? *) + subgoal `n'''' = n'` >- ( + Cases_on `n' < n'4'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'4' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> + gs [] + ) >> + Cases_on `n' > n'4'` >- ( + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''''`] >> + gs [] + ) >> + fs [] + ) >> + gs [] >> + QSPECL_X_ASSUM ``!n'5'. + n'5' < n' /\ n'5' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n'5' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''' + n''`] >> + gs [] >> + qexists_tac `ms''` >> + fs [] >> + irule FUNPOW_OPT_split >> + qexistsl_tac [`n'' + n'3'`, `s`] >> + fs [] + ] +) >> +fs [] >> +subgoal `(OLEAST n'. FUNPOW_OPT m.trs n' s'' = SOME s') = SOME (n' - n'')` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + conj_tac >| [ + irule FUNPOW_OPT_split >> + qexistsl_tac [`n'`, `s`] >> + fs [], + + rpt strip_tac >> + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n'' + n'''`] >> + gs [] >> + metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] + ] +) >> +fs [] >> +subgoal `s'' <> s'` >- ( + (* Since s'' NOTIN ls1, while s' IN ls1 *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + (* TODO: Make some kind of lemma here? *) + Q.SUBGOAL_THEN `n'3' = n'` (fn thm => fs [thm]) >- ( + Cases_on `n' < n'3'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + Cases_on `n' > n'3'` >- ( + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + fs [] + ) >> + QSPECL_X_ASSUM ``!n'5'. + n'5' < n' /\ n'5' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n'5' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> + gs [whileTheory.OLEAST_EQ_SOME] >> + strip_tac >> + fs [] +) >> +fs [] >> +qexists_tac `1 + n_l` >> +fs [] >> +irule weak_exec_n_OLEAST_inter >> +fs [] >> +qexistsl_tac [`n''`, `s''`] >> +fs [] +QED + +(* TODO: Generalise this *) +(* TODO: Change weak_exec_n 1 to weak? *) +Theorem weak_exec_1_superset: + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + weak_exec_n m ms ls1 1 = SOME ms' ==> + ms <> ms' ==> + ls1 SUBSET ls2 ==> + ?n. n >= 1 /\ (OLEAST n. weak_exec_n m ms ls2 n = SOME ms') = SOME n +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> +subgoal `?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' ms = SOME ms') = SOME n'` >- ( + (* Since weak goes from ms to ms', there must be a least number of primitive transitions such that + * ms goes to ms' *) + metis_tac [weak_least_trs] ) >> -qexists_tac `n_l` >> -gs [GSYM weak_exec_n_def] >> -metis_tac [weak_exec_n_count] +irule weak_exec_1_superset_lemma >> +fs [] >> +rpt strip_tac >| [ + qexists_tac `n'` >> + fs [], + + metis_tac [] +] QED (* TODO: Strengthen conclusion to state either ms'' is ms', or pc is in ls2? *) @@ -1011,11 +1503,13 @@ fs [weak_exec_def, weak_nonempty] >> metis_tac [weak_superset_thm] QED +(* Note: ms <> ms' used to avoid proving case where least n is zero *) Theorem weak_exec_n_exists_superset: !m. weak_model m ==> !ms ls1 ls2 ms'. m.weak ms ls1 ms' ==> + ms <> ms' ==> ?n. (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n Proof rpt strip_tac >> @@ -1063,53 +1557,6 @@ QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms' ==> x = y`` [`n gs [] QED -(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' - * Let this rely on sub-lemma for incrementing weak_exec_n instead - * of reasoning on FUNPOW_OPT *) -Theorem weak_exec_incr: - !m. - weak_model m ==> - !ms ls ms' n_l ms''. - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> - m.weak ms' ls ms'' ==> - weak_exec_n m ms ls (SUC n_l) = SOME ms'' -Proof -rpt strip_tac >> -simp [weak_exec_n_def, arithmeticTheory.ADD1] >> -ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> -irule FUNPOW_OPT_ADD_thm >> -qexists_tac `ms'` >> -fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> -simp [FUNPOW_OPT_def] >> -metis_tac [weak_exec_exists] -QED - -Theorem weak_inter_exec: - !m. - weak_model m ==> - !ms le l n_l ms' s'. - m.weak ms le ms' ==> - (OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME ms') = SOME n_l ==> - SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME s') ==> - m.weak s' le ms' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> -fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> -fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> -(* There is a number of trs X that goes from ms to ms'. - * There is also a strictly smaller (since x < n_l) number of trs Y that goes from ms to s'. - * ms' was the first state in le that was encountered by definition of weak, so performing a weak - * transition from s' (at Y steps) will always end up at ms'. *) - -(* TODO: Might need something like weak_intermediate_labels2 *) -(* OK: s' is a uniquely encountered (before n_l loop iterations) state, - * where n_l is the least amount of applications of weak_exec to ({l} UNION le) - * needed to exit the loop, - * therefore weak transition can continue from s' to the loop exit *) -cheat -QED (* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) Theorem weak_exec_incr_least: @@ -1125,7 +1572,7 @@ Theorem weak_exec_incr_least: (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME (SUC n_l') Proof rpt strip_tac >> -imp_res_tac weak_exec_incr >> +imp_res_tac weak_exec_incr_last >> fs [whileTheory.OLEAST_EQ_SOME] >> rpt strip_tac >> subgoal `SUC n_l' < n_l` >- ( @@ -1162,6 +1609,13 @@ Theorem weak_exec_uniqueness: Proof rpt strip_tac >> fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +(* s'' - - n - > s'' ==> + * min k . s - - k - > s' <> s'' ==> + * k < n + * Use lemma, then proof by contradiction on encountering earlier ms' + * Lemma for loop periodicity? +*) + (* Say there were another encounter of ms'' other than that at n_l' before * n_l. Then there could be no states other than those found in between * after them (due to cycle). But ms' was first encountered at n_l, @@ -1196,7 +1650,7 @@ rpt strip_tac >> Cases_on `SUC n_l' = n_l` >- ( subgoal `ms''' = ms'` >- ( subgoal `weak_exec_n m ms (ls1 UNION ls2) (SUC n_l') = SOME ms'''` >- ( - metis_tac [weak_exec_incr] + metis_tac [weak_exec_incr_last] ) >> gs [whileTheory.OLEAST_EQ_SOME] ) >> @@ -1257,6 +1711,9 @@ fs [weak_partial_loop_contract_def] >> (* 0. Establish n_l *) subgoal `?n_l. (OLEAST n. weak_exec_n m ms ({l} UNION le) n = SOME ms') = SOME n_l` >- ( ONCE_REWRITE_TAC [pred_setTheory.UNION_COMM] >> + subgoal `ms <> ms'` >- ( + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] + ) >> irule weak_exec_n_exists_superset >> fs [] ) >> @@ -1270,6 +1727,9 @@ subgoal `abstract_jgmt m l le (\s'. (^invariant) s' /\ ~(C1 s')) post` >- ( metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] ) >> subgoal `m.weak s' le ms'` >- ( + subgoal `DISJOINT {l} le` >- ( + fs [] + ) >> metis_tac [weak_inter_exec] ) >> fs [abstract_partial_jgmt_def] >> @@ -1297,6 +1757,9 @@ subgoal `abstract_loop_jgmt m l le (^invariant) C1 (^variant)` >- ( irule weak_superset_thm >> fs [] >> qexists_tac `ms'` >> + subgoal `DISJOINT {l} le` >- ( + fs [] + ) >> metis_tac [weak_inter_exec] ) >> subgoal `m.pc ms''' = l` >- ( @@ -1319,7 +1782,7 @@ subgoal `abstract_loop_jgmt m l le (^invariant) C1 (^variant)` >- ( fs [] >> metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm], - metis_tac [weak_exec_incr] + metis_tac [weak_exec_incr_last] ], metis_tac [] From 46e1658f3cba4c0e69145cabc6cae33953b2645a Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 30 May 2022 05:48:34 +0200 Subject: [PATCH 0111/1015] Fixed all cheats in weak_partial_loop_rule_thm --- .../abstract_hoare_logic_partialScript.sml | 520 +++++++++++++++--- 1 file changed, 430 insertions(+), 90 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 6bee5a356..90a798ad8 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -913,6 +913,242 @@ rw [] >> gs [FUNPOW_OPT_compute] QED +Theorem weak_exec_n_prev: + !m. + weak_model m ==> + !ms ls ms' n_l. + weak_exec_n m ms ls (SUC n_l) = SOME ms' ==> + ?ms''. weak_exec_n m ms ls n_l = SOME ms'' /\ weak_exec_n m ms'' ls 1 = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +subgoal `SUC n_l > 0` >- ( + fs [] +) >> +imp_res_tac FUNPOW_OPT_prev_EXISTS >> +QSPECL_X_ASSUM ``!n'. _`` [`n_l`] >> +fs [] >> +Cases_on `n_l = 0` >- ( + gs [FUNPOW_OPT_compute] +) >> +irule FUNPOW_OPT_split >> +qexistsl_tac [`SUC n_l`, `ms`] >> +fs [arithmeticTheory.ADD1] +QED + +Theorem weak_exec_n_least_trs_ind: + !m. + weak_model m ==> + !n_l n_l' s ls s'. + n_l <= n_l' /\ n_l > 0 ==> + weak_exec_n m s ls n_l = SOME s' ==> + ?n. n > 0 /\ (OLEAST n. FUNPOW_OPT m.trs n s = SOME s') = SOME n +Proof +ntac 2 strip_tac >> +Induct_on `n_l'` >- ( + rpt strip_tac >> + gvs [] +) >> +rpt strip_tac >> +(* We know there is one encounter at n_l, but there must also be some FIRST encounter of s' *) +(* TODO: This might require a lemma of its own... *) +subgoal `?n_l''. n_l'' <= n_l /\ n_l'' > 0 /\ (OLEAST n_l''. weak_exec_n m s ls n_l'' = SOME s') = SOME n_l''` >- ( + cheat +) >> +Cases_on `n_l'' = 1` >- ( + irule weak_least_trs >> + fs [whileTheory.OLEAST_EQ_SOME] >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> + conj_tac >| [ + QSPECL_X_ASSUM ``!n_l'3'. n_l'3' < 1 ==> weak_exec_n m s ls n_l'3' <> SOME s'`` [`0`] >> + fs [weak_exec_n_def, FUNPOW_OPT_compute], + + metis_tac [] + ] +) >> +subgoal `?s''. weak_exec_n m s ls (n_l'' - 1) = SOME s'' /\ weak_exec_n m s'' ls 1 = SOME s'` >- ( + irule weak_exec_n_prev >> + Cases_on `n_l''` >- ( + fs [] + ) >> + fs [whileTheory.OLEAST_EQ_SOME] +) >> +subgoal `?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s'') = SOME n'` >- ( + QSPECL_X_ASSUM ``!n_l. _`` [`n_l'' - 1`, `s`, `ls`, `s''`] >> + gs [] +) >> +subgoal `?n''. n'' > 0 /\ (OLEAST n''. FUNPOW_OPT m.trs n'' s'' = SOME s') = SOME n''` >- ( + irule weak_least_trs >> + fs [] >> + conj_tac >| [ + fs [whileTheory.OLEAST_EQ_SOME] >> + QSPECL_X_ASSUM ``!n_l'3'. n_l'3' < n_l'' ==> weak_exec_n m s ls n_l'3' <> SOME s'`` [`n_l'' - 1`] >> + gs [], + + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> + metis_tac [] + ] +) >> +qexists_tac `n' + n''` >> +fs [] >> +simp [whileTheory.OLEAST_EQ_SOME] >> +conj_tac >| [ + ONCE_REWRITE_TAC [arithmeticTheory.ADD_COMM] >> + irule FUNPOW_OPT_ADD_thm >> + qexists_tac `s''` >> + fs [whileTheory.OLEAST_EQ_SOME], + + (* TODO: This might require a lemma of its own... *) + subgoal `!n. n < n' ==> FUNPOW_OPT m.trs n s <> SOME s'` >- ( + cheat + ) >> + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_SOME] >> + Cases_on `n < n'` >- ( + metis_tac [] + ) >> + subgoal `?n'4'. n'4' < n'' /\ (FUNPOW_OPT m.trs n s = SOME s' <=> FUNPOW_OPT m.trs (n' + n'4') s = SOME s')` >- ( + qexists_tac `n - n'` >> + fs [] + ) >> + fs [] >> + subgoal `FUNPOW_OPT m.trs n'4' s'' = SOME s'` >- ( + irule FUNPOW_OPT_INTER >> + qexistsl_tac [`s`, `n'`] >> + fs [] + ) >> + metis_tac [] +] +QED + +(* +Theorem weak_exec_n_least_trs: + !m. + weak_model m ==> + !s ls s' n_l. + weak_exec_n m s ls n_l = SOME s' ==> + ?n. n > 0 /\ (OLEAST n. FUNPOW_OPT m.trs n s = SOME s') = SOME n +Proof +rpt strip_tac >> +irule weak_exec_n_least_trs_ind >> +fs [] >> +qexistsl_tac [`ls`, `n_l`, `n_l`] >> +fs [] +QED + +Theorem weak_exec_n_less_least_trs: + !m s ls s' s'' n_l n_l' n. + weak_model m ==> + weak_exec_n m s ls n_l = SOME s' ==> + weak_exec_n m s ls n_l' = SOME s'' ==> + n_l' < n_l ==> + (OLEAST n. FUNPOW_OPT m.trs n s = SOME s') = SOME n ==> + ?n'. n' > 0 /\ n' < n /\ (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s'') = SOME n' +Proof +cheat +QED +*) + +Theorem FUNPOW_OPT_cycle: + !f s s' n n'. + (OLEAST n. n > 0 /\ FUNPOW_OPT f n s = SOME s) = SOME n ==> + s <> s' ==> + (OLEAST n'. FUNPOW_OPT f n' s = SOME s') = SOME n' ==> + n' < n +Proof +rpt strip_tac >> +CCONTR_TAC >> +Cases_on `n' = n` >- ( + fs [whileTheory.OLEAST_EQ_SOME] +) >> +subgoal `n' > n` >- ( + gs [] +) >> +subgoal `FUNPOW_OPT f (n' - n) s = SOME s'` >- ( + irule FUNPOW_OPT_split2 >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `s` >> + fs [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT f n'' s <> SOME s'`` [`n' - n`] >> +gs [] +QED + +Theorem weak_exec_n_cycle: + !m s s' ls n_l n_l'. + weak_model m ==> + (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s) = SOME n_l ==> + s <> s' ==> + (OLEAST n_l'. weak_exec_n m s ls n_l' = SOME s') = SOME n_l' ==> + n_l' < n_l +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +metis_tac [FUNPOW_OPT_cycle] +QED + + +Theorem weak_exec_n_split: +!m. weak_model m ==> +!s s' s'' ls n n'. +n > n' ==> +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s ls (n - n') = SOME s'' ==> +weak_exec_n m s'' ls n' = SOME s' +Proof +cheat +QED + +Theorem weak_exec_n_split2: +!m. weak_model m ==> +!s s' s'' ls n n'. +n >= n' ==> +weak_exec_n m s ls n' = SOME s'' ==> +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s'' ls (n - n') = SOME s' +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +Cases_on `n = n'` >- ( + fs [FUNPOW_OPT_compute] +) >> +subgoal `n > n'` >- ( + fs [] +) >> +metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +QED + + +Theorem weak_exec_n_cycle_alt: + !m s s' ls n_l n_l'. + weak_model m ==> + n_l > 0 /\ weak_exec_n m s ls n_l = SOME s ==> + s <> s' ==> + (OLEAST n_l'. weak_exec_n m s ls n_l' = SOME s') = SOME n_l' ==> + n_l' < n_l +Proof +rpt strip_tac >> +CCONTR_TAC >> +Cases_on `n_l' = n_l` >- ( + fs [whileTheory.OLEAST_EQ_SOME] +) >> +subgoal `n_l' > n_l` >- ( + gs [] +) >> +subgoal `weak_exec_n m s ls (n_l' - n_l) = SOME s'` >- ( + irule weak_exec_n_split2 >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `s` >> + fs [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +QSPECL_X_ASSUM ``!n_l''. n_l'' < n_l' ==> weak_exec_n m s ls n_l'' <> SOME s'`` [`n_l' - n_l`] >> +gs [] +QED + (* TODO: Technically, this doesn't need OLEAST for the encounter of ms' * Let this rely on sub-lemma for incrementing weak_exec_n instead * of reasoning on FUNPOW_OPT *) @@ -951,29 +1187,6 @@ simp [FUNPOW_OPT_def] >> metis_tac [weak_exec_exists] QED -Theorem weak_exec_n_prev: - !m. - weak_model m ==> - !ms ls ms' n_l. - weak_exec_n m ms ls (SUC n_l) = SOME ms' ==> - ?ms''. weak_exec_n m ms ls n_l = SOME ms'' /\ weak_exec_n m ms'' ls 1 = SOME ms' -Proof -rpt strip_tac >> -fs [weak_exec_n_def] >> -subgoal `SUC n_l > 0` >- ( - fs [] -) >> -imp_res_tac FUNPOW_OPT_prev_EXISTS >> -QSPECL_X_ASSUM ``!n'. _`` [`n_l`] >> -fs [] >> -Cases_on `n_l = 0` >- ( - gs [FUNPOW_OPT_compute] -) >> -irule FUNPOW_OPT_split >> -qexistsl_tac [`SUC n_l`, `ms`] >> -fs [arithmeticTheory.ADD1] -QED - Theorem weak_union_pc: !m. weak_model m ==> @@ -1014,36 +1227,6 @@ fs [weak_exec_n_def] >> metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] QED -Theorem weak_exec_n_split: -!m. weak_model m ==> -!s s' s'' ls n n'. -n > n' ==> -weak_exec_n m s ls n = SOME s' ==> -weak_exec_n m s ls (n - n') = SOME s'' ==> -weak_exec_n m s'' ls n' = SOME s' -Proof -cheat -QED - -Theorem weak_exec_n_split2: -!m. weak_model m ==> -!s s' s'' ls n n'. -n >= n' ==> -weak_exec_n m s ls n' = SOME s'' ==> -weak_exec_n m s ls n = SOME s' ==> -weak_exec_n m s'' ls (n - n') = SOME s' -Proof -rpt strip_tac >> -fs [weak_exec_n_def] >> -Cases_on `n = n'` >- ( - fs [FUNPOW_OPT_compute] -) >> -subgoal `n > n'` >- ( - fs [] -) >> -metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] -QED - Theorem weak_exec_n_inter: !m. weak_model m ==> @@ -1596,6 +1779,7 @@ gs [] * needed to reach ms'' *) QED +(* (* TODO: m.weak ms ls2 ms' redundant? *) Theorem weak_exec_uniqueness: !m. @@ -1608,26 +1792,195 @@ Theorem weak_exec_uniqueness: SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') Proof rpt strip_tac >> -fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> -(* s'' - - n - > s'' ==> - * min k . s - - k - > s' <> s'' ==> - * k < n - * Use lemma, then proof by contradiction on encountering earlier ms' - * Lemma for loop periodicity? +fs [pred_setTheory.SING_DEF] >> +subgoal `weak_exec_n m ms'' (ls1 UNION ls2) (n_l - n_l') = SOME ms'` >- ( + irule weak_exec_n_split2 >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `ms` >> + fs [] +) >> +subgoal `?n. (OLEAST n. FUNPOW_OPT m.trs n ms = SOME ms'') = SOME n` >- ( + metis_tac [weak_exec_n_least_trs] +) >> +subgoal `?n'. (OLEAST n'. FUNPOW_OPT m.trs n' ms'' = SOME ms') = SOME n'` >- ( + metis_tac [weak_exec_n_least_trs] +) >> +qexists_tac `n_l'` >> +(* Suppose there is some other number of weak which can be applied to reach + * ms'' from ms *) +Cases_on `?n_l''. n_l'' <> n_l' /\ n_l'' IN (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'')` >- ( + fs [] >> + (* Then there is some other number of trs which can be applied to reach + * ms'' from ms *) + Cases_on `n_l'' < n_l'` >- ( + subgoal `?n''. n'' > 0 /\ n'' < n /\ (OLEAST n''. FUNPOW_OPT m.trs n'' ms = SOME ms'') = SOME n''` >- ( + metis_tac [weak_exec_n_less_least_trs] + ) >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [] + ) >> + Cases_on `n_l'' > n_l'` >- ( + (* There is a cycle between ms'' and ms'' *) + subgoal `weak_exec_n m ms'' (ls1 UNION ls2) (n_l'' - n_l') = SOME ms''` >- ( + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [] + ) >> + subgoal `?n''. (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' ms'' = SOME ms'') = SOME n''` >- ( + imp_res_tac weak_exec_n_least_trs >> + qexists_tac `n''` >> + fs [whileTheory.OLEAST_EQ_SOME] + ) >> + subgoal `ms'' <> ms'` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [] + ) >> + imp_res_tac weak_exec_n_cycle >> + (* Second encounter of ms'' is now after ms' in terms of trs (n'' vs. n', counting from ms), + * but this countradicts their order in terms of applications of weak (n_l'' vs. n_l) *) + subgoal `?n'''. + n''' > 0 /\ n''' < n /\ + (OLEAST n'''. FUNPOW_OPT m.trs n''' ms = SOME ms'') = SOME n'''` >- ( + (* weak_exec_n_less_least_trs *) + irule weak_exec_n_less_least_trs >> + fs [] >> + qexistsl_tac [`(ls1 UNION ls2)`, `n_l''`, `n_l'`, `ms''`] >> + fs [arithmeticTheory.GREATER_DEF] + ) >> + gs [] + ) >> + fs [] +) >> +gs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +rpt strip_tac >> +metis_tac [] +QED *) -(* Say there were another encounter of ms'' other than that at n_l' before - * n_l. Then there could be no states other than those found in between - * after them (due to cycle). But ms' was first encountered at n_l, - * which is not in the cycle between the two ms'', so there could be - * no such cycle, and thus not two ms'' before ms'. *) - -(* OK: ms'' is a state encountered before n_l loop iterations, - * where n_l is the least amount of applications of weak_exec to ({l} UNION le) - * needed to exit the loop, - * therefore ms'' must have been uniquely encountered before n_l loop iterations, - * or there must have been a loop before ms' could ever be reached *) -cheat +Theorem weak_exec_uniqueness_alt: + !m. + weak_model m ==> + !ms ls ms' ms'' ms''' n_l n_l'. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME n_l' ==> + n_l' < n_l ==> + m.weak ms'' ls ms''' ==> + ms''' <> ms' ==> + SING (\n_l''. n_l'' < n_l /\ weak_exec_n m ms ls n_l'' = SOME ms''') +Proof +rpt strip_tac >> +subgoal `weak_exec_n m ms ls (n_l' + 1) = SOME ms'3'` >- ( + irule weak_exec_n_add >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [weak_exec_exists, weak_exec_to_n] +) >> +(* Suppose there exists some earlier encounter of ms''' *) +Cases_on `?n_l''. n_l'' < (n_l' + 1) /\ weak_exec_n m ms ls n_l'' = SOME ms'''` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + subgoal `weak_exec_n m ms''' ls (n_l - (n_l' + 1)) = SOME ms'` >- ( + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [] + ) >> + subgoal `weak_exec_n m ms ls (n_l'' + (n_l - (n_l' + 1))) = SOME ms'` >- ( + irule weak_exec_n_add >> + fs [] >> + qexists_tac `ms'3'` >> + fs [] + ) >> + QSPECL_ASSUM ``!n. n < n_l ==> weak_exec_n m ms ls n <> SOME ms'`` [`(n_l'' + (n_l - (n_l' + 1)))`] >> + gs [] +) >> +fs [] >> +(* If there were no earlier encounter of ms''', then the first encounter was at n_l' + 1 *) +subgoal `(OLEAST n_l. weak_exec_n m ms ls n_l = SOME ms''') = SOME (n_l' + 1)` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [] +) >> + +(* Suppose there exists some later encounter of ms''' *) +Cases_on `?n_l''. n_l'' > (n_l' + 1) /\ n_l'' < n_l /\ weak_exec_n m ms ls n_l'' = SOME ms'''` >- ( + fs [] >> + subgoal `(OLEAST n_l. weak_exec_n m ms''' ls n_l = SOME ms') = SOME (n_l - (n_l' + 1))` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + rpt strip_tac >| [ + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [], + + (* TODO: Prove the OLEAST part... *) + subgoal `weak_exec_n m ms ls ((n_l' + 1) + n_l'3') <> SOME ms'` >- ( + QSPECL_ASSUM ``!n. n < n_l ==> weak_exec_n m ms ls n <> SOME ms'`` [`(n_l' + 1) + n_l'3'`] >> + gs [] + ) >> + subgoal `weak_exec_n m ms ls ((n_l' + 1) + n_l'3') = SOME ms'` >- ( + irule weak_exec_n_add >> + fs [] + ) + ] + ) >> + subgoal `weak_exec_n m ms''' ls (n_l'' - (n_l' + 1)) = SOME ms'''` >- ( + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [] + ) >> + (* By weak_exec_n_cycle *) + subgoal `(n_l - (n_l' + 1)) < (n_l'' - (n_l' + 1))` >- ( + irule weak_exec_n_cycle_alt >> + fs [] >> + qexistsl_tac [`ls`, `m`, `ms'''`, `ms'`] >> + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + gs [] +) >> +fs [] >> +gs [pred_setTheory.SING_DEF, GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +qexists_tac `n_l' + 1` >> +rpt strip_tac >| [ + Cases_on `n_l' + 1 = n_l` >- ( + gvs [whileTheory.OLEAST_EQ_SOME] + ) >> + gs [], + + irule weak_exec_n_add >> + fs [] >> + qexists_tac `ms''` >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [weak_exec_exists, weak_exec_to_n], + + res_tac >> + gs [arithmeticTheory.EQ_LESS_EQ, arithmeticTheory.NOT_LESS] +] +QED + +Theorem weak_exec_unique_start: + !m. + weak_model m ==> + !ms ls ms' n_l. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + ms <> ms' ==> + SING (\n_l'. n_l' < n_l /\ weak_exec_n m ms ls n_l' = SOME ms) +Proof +rpt strip_tac >> +gs [pred_setTheory.SING_DEF, GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +qexists_tac `0` >> +rpt strip_tac >| [ + Cases_on `n_l = 0` >> ( + fs [weak_exec_n_def, FUNPOW_OPT_compute, whileTheory.OLEAST_EQ_SOME] + ), + + fs [weak_exec_n_def, FUNPOW_OPT_compute], + + Cases_on `y > 0` >- ( + imp_res_tac weak_exec_n_cycle_alt >> + fs [] + ) >> + fs [] +] QED (* Uses the fact that exit labels are disjoint from loop point to know that @@ -1770,20 +2123,11 @@ subgoal `abstract_loop_jgmt m l le (^invariant) C1 (^variant)` >- ( subgoal `SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME ms'3')` >- ( (* Invariant is kept *) (* By uniqueness theorem (stating no duplicate states before ms' is reached) *) - irule weak_exec_uniqueness >> + irule weak_exec_uniqueness_alt >> fs [] >> conj_tac >| [ - qexists_tac `SUC n_l'` >> - conj_tac >| [ - (* Since ms''' <> ms' *) - irule weak_exec_less_incr_superset >> - fs [] >> - qexistsl_tac [`{l}`, `le`, `m`, `ms`, `ms'`, `s`, `ms'''`] >> - fs [] >> - metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm], - - metis_tac [weak_exec_incr_last] - ], + qexists_tac `ms'` >> + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm], metis_tac [] ] @@ -1821,14 +2165,10 @@ subgoal `SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME ms)` >- ( metis_tac [weak_exec_least_nonzero] ) >> (* By uniqueness theorem (stating no duplicate states before ms' is reached) *) - irule weak_exec_uniqueness >> + irule weak_exec_unique_start >> fs [] >> - conj_tac >| [ - qexists_tac `0` >> - fs [], - - metis_tac [] - ] + qexists_tac `ms'` >> + metis_tac [weak_pc_in_thm, IN_NOT_IN_NEQ_thm] ) >> gs [] >> metis_tac [weak_unique_thm] From aa298666ce5628743c2b7c18c9b9ae6003dd44db Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 30 May 2022 05:57:34 +0200 Subject: [PATCH 0112/1015] A little cleanup --- .../abstract_hoare_logic_partialScript.sml | 802 +----------------- 1 file changed, 7 insertions(+), 795 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 90a798ad8..c38d856b9 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -8,20 +8,6 @@ open abstract_hoare_logic_auxTheory abstract_hoare_logicTheory; val _ = new_theory "abstract_hoare_logic_partial"; -(* TODO: Do away with this and everything related to it? *) -Definition weak_rel_steps_def: - weak_rel_steps m ms ls ms' n = - ((n > 0 /\ - FUNPOW_OPT m.trs n ms = SOME ms' /\ - m.pc ms' IN ls) /\ - !n'. - (n' < n /\ n' > 0 ==> - ?ms''. - FUNPOW_OPT m.trs n' ms = SOME ms'' /\ - ~(m.pc ms'' IN ls) - )) -End - Definition ominus_def: (ominus NONE _ = NONE) /\ (ominus _ NONE = NONE) /\ @@ -55,532 +41,6 @@ qexistsl_tac [`s`, `n - n'`] >> fs [] QED -Theorem weak_rel_steps_imp: - !m ms ls ms' n. - weak_model m ==> - (weak_rel_steps m ms ls ms' n ==> - m.weak ms ls ms') -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -qexists_tac `n` >> -fs [weak_rel_steps_def] -QED - -Theorem weak_rel_steps_equiv: - !m ms ls ms'. - weak_model m ==> - (m.weak ms ls ms' <=> - ?n. weak_rel_steps m ms ls ms' n) -Proof -rpt strip_tac >> -EQ_TAC >> ( - strip_tac -) >| [ - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - qexists_tac `n` >> - fs [weak_rel_steps_def], - - metis_tac [weak_rel_steps_imp] -] -QED - -Theorem weak_rel_steps_label: - !m ms ls ms' n. - weak_model m ==> - weak_rel_steps m ms ls ms' n ==> - m.pc ms' IN ls -Proof -fs [weak_rel_steps_def] -QED - -(* TODO: Contains cheats *) -Theorem weak_rel_steps_to_FUNPOW_OPT_LIST: - !m ms ls ms' n. - weak_model m ==> - (weak_rel_steps m ms ls ms' n <=> - n > 0 /\ - ?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) /\ - INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (PRE n, ms')) -Proof -rpt strip_tac >> -EQ_TAC >> ( - rpt strip_tac -) >| [ - fs [weak_rel_steps_def], - - fs [weak_rel_steps_def] >> - IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS_exact >> - fs [] >> - fs [INDEX_FIND_EQ_SOME_0, FUNPOW_OPT_LIST_EQ_SOME] >> - rpt strip_tac >| [ - rw [] >> - fs [EL_LAST_APPEND], - - QSPECL_X_ASSUM ``!n'. n' < n /\ n' > 0 ==> m.pc (EL n' (ms::SNOC ms' l)) NOTIN ls`` [`SUC j'`] >> - gs [listTheory.SNOC_APPEND] - ], - - fs [FUNPOW_OPT_LIST_EQ_SOME, INDEX_FIND_EQ_SOME_0, weak_rel_steps_def] >> - rpt strip_tac >| [ - fs [listTheory.LAST_DEF] >> - subgoal `ms_list <> []` >- ( - Cases_on `ms_list` >> ( - fs [] - ) - ) >> - rw [] >> - metis_tac [listTheory.LAST_EL], - - QSPECL_X_ASSUM ``!j'. j' < PRE n ==> m.pc (EL j' ms_list) NOTIN ls`` [`PRE n'`] >> - gs [] >> - `EL n' (ms::ms_list) = EL (PRE n') ms_list` suffices_by ( - strip_tac >> - fs [] - ) >> - irule rich_listTheory.EL_CONS >> - fs [] - ] -] -QED - - -(* If ms and ms' are not related by weak transition to ls for n transitions, - * but if taking n transitions from ms takes you to ms' with a label in ls, - * then there has to exist an ms'' and a *smallest* n' such that the label of - * ms'' is in ls. *) -(* TODO: Lemmatize further *) -(* TODO: Contains cheats *) -Theorem weak_rel_steps_smallest_exists: - !m. - weak_model m ==> - !ms ls ms' n. - ~(weak_rel_steps m ms ls ms' n) ==> - n > 0 ==> - FUNPOW_OPT m.trs n ms = SOME ms' ==> - m.pc ms' IN ls ==> - ?n' ms''. - n' < n /\ n' > 0 /\ - FUNPOW_OPT m.trs n' ms = SOME ms'' /\ - m.pc ms'' IN ls /\ - (!n''. - (n'' < n' /\ n'' > 0 ==> - ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ - ~(m.pc ms''' IN ls))) -Proof -rpt strip_tac >> -fs [weak_rel_steps_def] >> -subgoal `?ms_list. FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list)` >- ( - IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST m.trs n' ms = SOME l`` [`n`] >> - fs [] >> - Cases_on `n` >- ( - fs [FUNPOW_OPT_LIST_def] - ) >> - qexists_tac `DROP 1 l` >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n'. n' <= SUC n'' ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' l)`` [`0`] >> - fs [FUNPOW_OPT_def] >> - Cases_on `l` >> ( - fs [] - ) -) >> -subgoal `?i ms''. INDEX_FIND 0 (\ms. m.pc ms IN ls) ms_list = SOME (i, ms'')` >- ( - (* OK: There is at least ms', possibly some earlier encounter of ls *) - irule INDEX_FIND_MEM >> - qexists_tac `ms'` >> - fs [listTheory.MEM_EL] >> - qexists_tac `PRE n` >> - CONJ_TAC >| [ - IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - fs [], - - REWRITE_TAC [Once EQ_SYM_EQ] >> - irule FUNPOW_OPT_LIST_EL >> - fs [] >> - subgoal `?ms''. m.trs ms = SOME ms''` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`1`] >> - fs [FUNPOW_OPT_def] - ) >> - qexists_tac `m.trs` >> - qexists_tac `PRE n` >> - qexists_tac `ms''` >> - fs [] >> - CONJ_TAC >| [ - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - metis_tac [FUNPOW_OPT_PRE], - - metis_tac [FUNPOW_OPT_LIST_FIRST] - ] - ] -) >> -qexists_tac `SUC i` >> -qexists_tac `ms''` >> -fs [] >> -subgoal `?ms'''. FUNPOW_OPT m.trs n' ms = SOME ms'''` >- ( - metis_tac [FUNPOW_OPT_prev_EXISTS] -) >> -rpt strip_tac >| [ - (* i < n since i must be at least n', since INDEX_FIND at least must have found ms''', - * if not any earlier encounter *) - fs [INDEX_FIND_EQ_SOME_0] >> - Cases_on `n' < (SUC i)` >| [ - (* Contradiction: ms''' occurs earlier than the first encounter of ls found by INDEX_FIND *) - subgoal `m.pc (EL (PRE n') ms_list) NOTIN ls` >- ( - fs [] - ) >> - subgoal `(EL (PRE n') ms_list) = ms'''` >- ( - subgoal `(EL n' (ms::ms_list)) = ms'''` >- ( - metis_tac [FUNPOW_OPT_LIST_EL, arithmeticTheory.LESS_IMP_LESS_OR_EQ] - ) >> - metis_tac [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] - ) >> - fs [], - - fs [] - ], - - fs [INDEX_FIND_EQ_SOME_0, FUNPOW_OPT_LIST_EQ_SOME], - - fs [INDEX_FIND_EQ_SOME], - - subgoal `n'' < n` >- ( - fs [INDEX_FIND_EQ_SOME_0] >> - IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - fs [] - ) >> - subgoal `?ms''''. FUNPOW_OPT m.trs n'' ms = SOME ms''''` >- ( - metis_tac [FUNPOW_OPT_LIST_EL_SOME, arithmeticTheory.LESS_IMP_LESS_OR_EQ] - ) >> - subgoal `(EL (PRE n'') ms_list) = ms''''` >- ( - irule FUNPOW_OPT_LIST_EL >> - subgoal `?ms'''''. m.trs ms = SOME ms'''''` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT m.trs n' ms = SOME (EL n' (ms::ms_list))`` [`1`] >> - fs [FUNPOW_OPT_def] - ) >> - qexists_tac `m.trs` >> - qexists_tac `PRE n` >> - qexists_tac `ms'''''` >> - fs [] >> - rpt CONJ_TAC >| [ - irule arithmeticTheory.PRE_LESS_EQ >> - fs [], - - metis_tac [FUNPOW_OPT_PRE], - - subgoal `n > 0` >- ( - fs [] - ) >> - metis_tac [FUNPOW_OPT_LIST_PRE] - ] - ) >> - fs [INDEX_FIND_EQ_SOME_0] >> - rw [] -] -QED - -Theorem weak_rel_steps_intermediate_labels: - !m. - weak_model m ==> - !ms ls1 ls2 ms' n. - weak_rel_steps m ms ls1 ms' n ==> - ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> - ?ms'' n'. weak_rel_steps m ms ls2 ms'' n' /\ n' < n -Proof -rpt strip_tac >> -fs [weak_rel_steps_def] >> -rfs [] >> -subgoal `?n' ms''. - n' < n /\ n' > 0 /\ - FUNPOW_OPT m.trs n' ms = SOME ms'' /\ - (m.pc ms'' IN (ls1 UNION ls2)) /\ - (!n''. - (n'' < n' /\ n'' > 0 ==> - ?ms'''. FUNPOW_OPT m.trs n'' ms = SOME ms''' /\ - ~(m.pc ms''' IN (ls1 UNION ls2))))` >- ( - irule weak_rel_steps_smallest_exists >> - fs [weak_rel_steps_def] >> - qexists_tac `n'` >> - rpt strip_tac >> ( - fs [] - ) -) >> -qexists_tac `ms''` >> -qexists_tac `n''` >> -fs [] >| [ - QSPECL_X_ASSUM ``!(n':num). n' < n /\ n' > 0 ==> _`` [`n''`] >> - rfs [], - - rpt strip_tac >> - QSPECL_X_ASSUM ``!(n'3':num). n'3' < n'' /\ n'3' > 0 ==> _`` [`n'3'`] >> - rfs [] -] -QED - -Theorem weak_rel_steps_union: - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' n n'. - weak_rel_steps m ms ls1 ms' n ==> - weak_rel_steps m ms ls2 ms'' n' ==> - n' < n ==> - weak_rel_steps m ms (ls1 UNION ls2) ms'' n' -Proof -rpt strip_tac >> -fs [weak_rel_steps_def] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> -QSPECL_X_ASSUM ``!n'. _`` [`n''`] >> -rfs [] >> -fs [] -QED - -Theorem weak_intermediate_labels: - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - m.weak ms ls1 ms' ==> - ~(m.weak ms (ls1 UNION ls2) ms') ==> - ?ms''. (m.pc ms'') IN ls2 /\ m.weak ms (ls1 UNION ls2) ms'' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> -QSPECL_X_ASSUM ``!n. _`` [`n`] >> -IMP_RES_TAC weak_rel_steps_intermediate_labels >> -qexists_tac `ms''` >> -CONJ_TAC >| [ - metis_tac [weak_rel_steps_label], - - metis_tac [weak_rel_steps_union] -] -QED - -Theorem weak_rel_steps_unique: - !m. - weak_model m ==> - !ms ls ms' ms'' n n'. - weak_rel_steps m ms ls ms' n ==> - weak_rel_steps m ms ls ms'' n' ==> - (ms' = ms'' /\ n = n') -Proof -rpt strip_tac >| [ - metis_tac [weak_rel_steps_imp, weak_unique_thm], - - fs [weak_rel_steps_def] >> - CCONTR_TAC >> - Cases_on `n < n'` >- ( - QSPECL_X_ASSUM ``!n''. _`` [`n`] >> - rfs [] - ) >> - QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls`` [`n'`] >> - rfs [] -] -QED - -(* If weak transition to ls connects ms to ms' via n transitions, then if for all - * numbers of transitions n' - !ms ls ms' ms'' n n'. - n' < n ==> - weak_rel_steps m ms ls ms' n ==> - FUNPOW_OPT m.trs n' ms = SOME ms'' ==> - weak_rel_steps m ms'' ls ms' (n - n') - ``, - -rpt strip_tac >> -fs [weak_rel_steps_def] >> -Cases_on `n'` >- ( - fs [FUNPOW_OPT_REWRS] -) >> -rpt strip_tac >| [ - irule FUNPOW_OPT_INTER >> - qexists_tac `ms` >> - qexists_tac `SUC n''` >> - fs [], - - QSPECL_X_ASSUM ``!n'. _`` [`SUC n'' + n'`] >> - rfs [] >> - metis_tac [FUNPOW_OPT_INTER] -] -); -*) - -(* If weak transition to ls connects ms to ms' via n transitions, and ms'' to ms' - * via n-n' transitions, then if for all non-zero transitions n'' lower than n-n' - * ls' is not encountered, then - * weak transition to (ls' UNION ls) connects ms'' to ms' via n-n' transitions. *) -(* -val weak_rel_steps_superset_after = prove(`` - !m. - weak_model m ==> - !ms ls ls' ms' n. - weak_rel_steps m ms ls ms' n ==> -(* Note: this is exactly the second conjunct of weak_rel_steps *) - (!n'. n' < n /\ n' > 0 ==> (?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls')) ==> -(* TODO: This formulation also possible (end point must now also be in ls'): - weak_rel_steps m ms ls' ms' n' ==> -*) - weak_rel_steps m ms (ls UNION ls') ms' n - ``, - -rpt strip_tac >> -fs [weak_rel_steps_def] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> -QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> -rfs [] >> -fs [] -); -*) - -Theorem weak_rel_steps_intermediate_labels2: - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' n n'. - weak_rel_steps m ms ls2 ms' n ==> - ~(weak_rel_steps m ms (ls1 UNION ls2) ms' n) ==> - weak_rel_steps m ms (ls1 UNION ls2) ms'' n' ==> - ?n''. weak_rel_steps m ms'' ls2 ms' n'' /\ n'' < n -Proof -rpt strip_tac >> -subgoal `weak_rel_steps m ms (ls1 UNION ls2) ms'' n' /\ n' < n` >- ( - subgoal `?ms'' n'. weak_rel_steps m ms (ls1 UNION ls2) ms'' n' /\ n' < n` >- ( - metis_tac [weak_rel_steps_intermediate_labels, weak_rel_steps_union, pred_setTheory.UNION_COMM] - ) >> - metis_tac [weak_rel_steps_unique] -) >> -fs [] >> -fs [weak_rel_steps_def] >> -rfs [] >> ( - qexists_tac `n - n'` >> - subgoal `FUNPOW_OPT m.trs (n - n') ms'' = SOME ms'` >- ( - metis_tac [FUNPOW_OPT_split2, arithmeticTheory.GREATER_DEF] - ) >> - fs [] >> - rpt strip_tac >> - QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n' + n'3'`] >> - subgoal `n' + n'3' < n` >- ( - fs [] - ) >> - subgoal `n' + n'3' > 0` >- ( - fs [] - ) >> - fs [] >> - qexists_tac `ms'3'` >> - fs [] >> - metis_tac [FUNPOW_OPT_INTER, arithmeticTheory.ADD_SYM] -) -QED - -Theorem weak_rel_steps_intermediate_labels3: - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' n n'. - weak_rel_steps m ms ls1 ms' n ==> - weak_rel_steps m ms (ls2 UNION ls1) ms'' n' ==> - n' < n ==> - m.pc ms'' IN ls2 -Proof -rpt strip_tac >> -fs [weak_rel_steps_def] >> -QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> -rfs [] -QED - -Theorem weak_intermediate_labels2: - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms''. - m.weak ms ls2 ms' ==> - ~(m.weak ms (ls1 UNION ls2) ms') ==> - m.weak ms (ls1 UNION ls2) ms'' ==> - m.weak ms'' ls2 ms' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_rel_steps_equiv thm]) >> -metis_tac [weak_rel_steps_intermediate_labels2] -QED - -(* -val weak_rel_steps_FILTER_inter = prove(`` - !m. - weak_model m ==> - !ms ls ms' i i' i'' l ms_list ms_list'. - weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> - EL i' ms_list = EL i (FILTER (\ms. m.pc ms = l) ms_list) ==> - EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> - i < LENGTH ms_list' - 1 ==> - FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> - weak_rel_steps m (EL i ms_list') ({l} UNION ls) (EL (i + 1) ms_list') (i'' - i') - ``, - -rpt strip_tac >> -fs [FUNPOW_OPT_LIST_EQ_SOME] >> -(* TODO: Problem is, EL i' ms_list and EL i'' ms_list may not be unique in ms_list *) -cheat -); -*) - -(* -val weak_rel_steps_FILTER_end = prove(`` - !m. - weak_model m ==> - !ms ls ms' i i'' l ms_list ms_list'. - weak_rel_steps m ms ls ms' (LENGTH ms_list) ==> - FUNPOW_OPT_LIST m.trs (LENGTH ms_list) ms = SOME (ms::ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> - i < LENGTH ms_list' - 1 ==> - EL i'' ms_list = EL (i+1) (FILTER (\ms. m.pc ms = l) ms_list) ==> - weak_rel_steps m (EL (i + 1) ms_list') ls ms' (LENGTH ms_list - SUC i'') - ``, - -rpt strip_tac >> -irule weak_rel_steps_intermediate_start >> -fs [] >> -CONJ_TAC >| [ - (* TODO: SUC i'' < LENGTH ms_list from main proof goal? *) - cheat, - - qexists_tac `ms` >> - fs [] >> - (* TODO: Should be OK if we have SUC i'' < LENGTH ms_list *) - cheat -] -); -*) -(* -val weak_rel_steps_FILTER_NOTIN_end = prove(`` - !m. - weak_model m ==> - !ms ls ms' n n' l ms_list ms_list'. - weak_rel_steps m ms ls ms' n ==> - l NOTIN ls ==> - FUNPOW_OPT_LIST m.trs n ms = SOME (ms::ms_list) ==> - FILTER (\ms. m.pc ms = l) ms_list = ms_list' ==> - EL (PRE (LENGTH (FILTER (\ms. m.pc ms = l) ms_list))) (FILTER (\ms. m.pc ms = l) ms_list) = EL n' ms_list ==> - SUC n' < n - ``, - -rpt strip_tac >> -(* TODO: Unclear? *) -cheat -); -*) - - Definition abstract_partial_jgmt_def: abstract_partial_jgmt m (l:'a) (ls:'a->bool) pre post = !ms ms'. @@ -627,6 +87,7 @@ rpt strip_tac >> metis_tac [weak_pc_in_thm] QED +(* TODO Fix this... Theorem weak_partial_subset_rule_thm: !m. !l ls1 ls2 pre post. weak_model m ==> @@ -645,12 +106,15 @@ Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( subgoal `?n. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( metis_tac [weak_model_def] ) >> +(* TODO: Fix this IMP_RES_TAC weak_intermediate_labels >> QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms''`] >> rfs [] >> metis_tac [] +*) +cheat QED - +*) Theorem weak_partial_conj_rule_thm: !m. @@ -936,120 +400,6 @@ qexistsl_tac [`SUC n_l`, `ms`] >> fs [arithmeticTheory.ADD1] QED -Theorem weak_exec_n_least_trs_ind: - !m. - weak_model m ==> - !n_l n_l' s ls s'. - n_l <= n_l' /\ n_l > 0 ==> - weak_exec_n m s ls n_l = SOME s' ==> - ?n. n > 0 /\ (OLEAST n. FUNPOW_OPT m.trs n s = SOME s') = SOME n -Proof -ntac 2 strip_tac >> -Induct_on `n_l'` >- ( - rpt strip_tac >> - gvs [] -) >> -rpt strip_tac >> -(* We know there is one encounter at n_l, but there must also be some FIRST encounter of s' *) -(* TODO: This might require a lemma of its own... *) -subgoal `?n_l''. n_l'' <= n_l /\ n_l'' > 0 /\ (OLEAST n_l''. weak_exec_n m s ls n_l'' = SOME s') = SOME n_l''` >- ( - cheat -) >> -Cases_on `n_l'' = 1` >- ( - irule weak_least_trs >> - fs [whileTheory.OLEAST_EQ_SOME] >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> - conj_tac >| [ - QSPECL_X_ASSUM ``!n_l'3'. n_l'3' < 1 ==> weak_exec_n m s ls n_l'3' <> SOME s'`` [`0`] >> - fs [weak_exec_n_def, FUNPOW_OPT_compute], - - metis_tac [] - ] -) >> -subgoal `?s''. weak_exec_n m s ls (n_l'' - 1) = SOME s'' /\ weak_exec_n m s'' ls 1 = SOME s'` >- ( - irule weak_exec_n_prev >> - Cases_on `n_l''` >- ( - fs [] - ) >> - fs [whileTheory.OLEAST_EQ_SOME] -) >> -subgoal `?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s'') = SOME n'` >- ( - QSPECL_X_ASSUM ``!n_l. _`` [`n_l'' - 1`, `s`, `ls`, `s''`] >> - gs [] -) >> -subgoal `?n''. n'' > 0 /\ (OLEAST n''. FUNPOW_OPT m.trs n'' s'' = SOME s') = SOME n''` >- ( - irule weak_least_trs >> - fs [] >> - conj_tac >| [ - fs [whileTheory.OLEAST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n_l'3'. n_l'3' < n_l'' ==> weak_exec_n m s ls n_l'3' <> SOME s'`` [`n_l'' - 1`] >> - gs [], - - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> - metis_tac [] - ] -) >> -qexists_tac `n' + n''` >> -fs [] >> -simp [whileTheory.OLEAST_EQ_SOME] >> -conj_tac >| [ - ONCE_REWRITE_TAC [arithmeticTheory.ADD_COMM] >> - irule FUNPOW_OPT_ADD_thm >> - qexists_tac `s''` >> - fs [whileTheory.OLEAST_EQ_SOME], - - (* TODO: This might require a lemma of its own... *) - subgoal `!n. n < n' ==> FUNPOW_OPT m.trs n s <> SOME s'` >- ( - cheat - ) >> - rpt strip_tac >> - fs [whileTheory.OLEAST_EQ_SOME] >> - Cases_on `n < n'` >- ( - metis_tac [] - ) >> - subgoal `?n'4'. n'4' < n'' /\ (FUNPOW_OPT m.trs n s = SOME s' <=> FUNPOW_OPT m.trs (n' + n'4') s = SOME s')` >- ( - qexists_tac `n - n'` >> - fs [] - ) >> - fs [] >> - subgoal `FUNPOW_OPT m.trs n'4' s'' = SOME s'` >- ( - irule FUNPOW_OPT_INTER >> - qexistsl_tac [`s`, `n'`] >> - fs [] - ) >> - metis_tac [] -] -QED - -(* -Theorem weak_exec_n_least_trs: - !m. - weak_model m ==> - !s ls s' n_l. - weak_exec_n m s ls n_l = SOME s' ==> - ?n. n > 0 /\ (OLEAST n. FUNPOW_OPT m.trs n s = SOME s') = SOME n -Proof -rpt strip_tac >> -irule weak_exec_n_least_trs_ind >> -fs [] >> -qexistsl_tac [`ls`, `n_l`, `n_l`] >> -fs [] -QED - -Theorem weak_exec_n_less_least_trs: - !m s ls s' s'' n_l n_l' n. - weak_model m ==> - weak_exec_n m s ls n_l = SOME s' ==> - weak_exec_n m s ls n_l' = SOME s'' ==> - n_l' < n_l ==> - (OLEAST n. FUNPOW_OPT m.trs n s = SOME s') = SOME n ==> - ?n'. n' > 0 /\ n' < n /\ (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s'') = SOME n' -Proof -cheat -QED -*) Theorem FUNPOW_OPT_cycle: !f s s' n n'. @@ -1090,7 +440,7 @@ fs [weak_exec_n_def] >> metis_tac [FUNPOW_OPT_cycle] QED - +(* TODO: Useful? Theorem weak_exec_n_split: !m. weak_model m ==> !s s' s'' ls n n'. @@ -1101,6 +451,7 @@ weak_exec_n m s'' ls n' = SOME s' Proof cheat QED +*) Theorem weak_exec_n_split2: !m. weak_model m ==> @@ -1293,14 +644,6 @@ Proof rpt strip_tac >> PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) >> -(* -subgoal `ms' <> ms''` >- ( - fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> - fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> - QSPECL_X_ASSUM ``!n. n < n_l ==> weak_exec_n m ms (ls1 UNION ls2) n <> SOME ms'`` [`x`] >> - gs [] -) >> -*) irule weak_exec_n_inter >> fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> @@ -1337,31 +680,6 @@ PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)] PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) QED -(* For suffices_by in below proof -Theorem TEST_lemma: - !m. weak_model m ==> - !s s' s'' ls n_l. - s <> s' ==> - s'' <> s' ==> - n_l > 0 ==> - weak_exec_n m s ls 1 = SOME s'' ==> - weak_exec_n m s ls 1 <> SOME s' /\ (!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s') ==> - !n_l'. n_l' < n_l + 1 ==> weak_exec_n m s ls n_l' <> SOME s' -Proof -rpt strip_tac >> -fs [] >> -QSPECL_X_ASSUM ``!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'`` [`n_l' - 1`] >> -gs [] >> -subgoal `n_l' >= 1` >- ( - Cases_on `n_l' = 0` >- ( - fs [weak_exec_n_def, FUNPOW_OPT_compute] - ) >> - fs [] -) >> -metis_tac [weak_exec_n_split2] -QED -*) - (* Continuing weak_exec_n at s'', intermediately between s and s'' *) Theorem weak_exec_n_OLEAST_inter: !m. weak_model m ==> @@ -1779,85 +1097,6 @@ gs [] * needed to reach ms'' *) QED -(* -(* TODO: m.weak ms ls2 ms' redundant? *) -Theorem weak_exec_uniqueness: - !m. - weak_model m ==> - !ms ls1 ls2 ms' n_l. - m.weak ms ls2 ms' ==> - (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> - !n_l' ms''. n_l' < n_l ==> - weak_exec_n m ms (ls1 UNION ls2) n_l' = SOME ms'' ==> - SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') -Proof -rpt strip_tac >> -fs [pred_setTheory.SING_DEF] >> -subgoal `weak_exec_n m ms'' (ls1 UNION ls2) (n_l - n_l') = SOME ms'` >- ( - irule weak_exec_n_split2 >> - fs [whileTheory.OLEAST_EQ_SOME] >> - qexists_tac `ms` >> - fs [] -) >> -subgoal `?n. (OLEAST n. FUNPOW_OPT m.trs n ms = SOME ms'') = SOME n` >- ( - metis_tac [weak_exec_n_least_trs] -) >> -subgoal `?n'. (OLEAST n'. FUNPOW_OPT m.trs n' ms'' = SOME ms') = SOME n'` >- ( - metis_tac [weak_exec_n_least_trs] -) >> -qexists_tac `n_l'` >> -(* Suppose there is some other number of weak which can be applied to reach - * ms'' from ms *) -Cases_on `?n_l''. n_l'' <> n_l' /\ n_l'' IN (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'')` >- ( - fs [] >> - (* Then there is some other number of trs which can be applied to reach - * ms'' from ms *) - Cases_on `n_l'' < n_l'` >- ( - subgoal `?n''. n'' > 0 /\ n'' < n /\ (OLEAST n''. FUNPOW_OPT m.trs n'' ms = SOME ms'') = SOME n''` >- ( - metis_tac [weak_exec_n_less_least_trs] - ) >> - fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [] - ) >> - Cases_on `n_l'' > n_l'` >- ( - (* There is a cycle between ms'' and ms'' *) - subgoal `weak_exec_n m ms'' (ls1 UNION ls2) (n_l'' - n_l') = SOME ms''` >- ( - irule weak_exec_n_split2 >> - fs [] >> - qexists_tac `ms` >> - fs [] - ) >> - subgoal `?n''. (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' ms'' = SOME ms'') = SOME n''` >- ( - imp_res_tac weak_exec_n_least_trs >> - qexists_tac `n''` >> - fs [whileTheory.OLEAST_EQ_SOME] - ) >> - subgoal `ms'' <> ms'` >- ( - fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [] - ) >> - imp_res_tac weak_exec_n_cycle >> - (* Second encounter of ms'' is now after ms' in terms of trs (n'' vs. n', counting from ms), - * but this countradicts their order in terms of applications of weak (n_l'' vs. n_l) *) - subgoal `?n'''. - n''' > 0 /\ n''' < n /\ - (OLEAST n'''. FUNPOW_OPT m.trs n''' ms = SOME ms'') = SOME n'''` >- ( - (* weak_exec_n_less_least_trs *) - irule weak_exec_n_less_least_trs >> - fs [] >> - qexistsl_tac [`(ls1 UNION ls2)`, `n_l''`, `n_l'`, `ms''`] >> - fs [arithmeticTheory.GREATER_DEF] - ) >> - gs [] - ) >> - fs [] -) >> -gs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> -rpt strip_tac >> -metis_tac [] -QED -*) - Theorem weak_exec_uniqueness_alt: !m. weak_model m ==> @@ -2012,33 +1251,6 @@ Cases_on `SUC n_l' = n_l` >- ( fs [] QED -(* -Theorem weak_exec_less: - !m. - weak_model m ==> - !ms ls ms' n_l n_l'. - SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms') ==> - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' ==> - n_l' < n_l -Proof -cheat -QED -*) - -(* -Theorem weak_exec_comp1: - !m. - weak_model m ==> - !ms ls ms' n n' ms''. - weak_exec_n m ms ls n = SOME ms' ==> - weak_exec_n m ms ls n' = SOME ms'' ==> - n < n' ==> - weak_exec_n m ms ls (n - n') = SOME ms'' -Proof -cheat -QED -*) - (* Invariant: *) (* TODO: Is SING useful enough or do we need LEAST? *) From dce3c84b82446e5b5205e5c9034dd7b30d2dfe9d Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Mon, 30 May 2022 06:07:12 +0200 Subject: [PATCH 0113/1015] All cheats now cleaned up --- .../abstract_hoare_logic_auxScript.sml | 1249 +---------------- .../abstract_hoare_logic_partialScript.sml | 67 +- 2 files changed, 37 insertions(+), 1279 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index e15a39c8c..730f28150 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -146,65 +146,6 @@ rpt strip_tac >| [ ] QED -(* TODO: Lemma stating no member of a filtered list has an index in the original list less than head of filtered list *) -Theorem FILTER_HD_OLEAST: - !P l l' x i i'. - FILTER P l = l' ==> - (OLEAST i. oEL i l = SOME (HD l')) = SOME i ==> - MEM x l' ==> - (OLEAST i. oEL i l = SOME x) = SOME i' ==> - i <= i' -Proof -cheat -(* -rpt strip_tac >> -CCONTR_TAC >> -subgoal `MEM (EL i' l) l'` >- ( - cheat -) >> -subgoal `HD l' <> x` >- ( - cheat -) >> -subgoal `0 < i'` >- ( - cheat -) >> -QSPECL_X_ASSUM ``!i''. i'' < i' ==> EL i'' l = x ==> ~(i'' < LENGTH l)`` [`0`] >> -gs [] >> -QSPECL_X_ASSUM ``!i''. i'' < i ==> EL i'' l <> HD l'`` [`0`] >> -gs [] >> -Cases_on `i = 0` >- ( - fs [] -) >> -gs [] >> -*) - - -(* -rpt strip_tac >> -fs [listTheory.MEM_EL] >> -qpat_x_assum `x = EL n l'` (fn thm => fs [thm]) >> -Cases_on `n` >- ( - cheat -) >> -fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> -Cases_on `i = 0` >- ( - fs [] -) >> -Cases_on `i' = 0` >- ( - fs [] >> - QSPECL_X_ASSUM ``!i''. i'' < i ==> EL i'' l = HD l' ==> ~(i'' < LENGTH l)`` [`i'`] >> - gs [] >> - cheat -) >> -Cases_on `i' < i` >- ( - fs [] >> - QSPECL_X_ASSUM ``!i''. i'' < i ==> EL i'' l = HD l' ==> ~(i'' < LENGTH l)`` [`i'`] >> - rfs [] >> - QSPECL_X_ASSUM ``!i''. i'' < i' ==> EL i'' l <> EL (SUC n') l'`` [`0`] >> - fs [] -) -*) -QED Theorem FILTER_HD_OLEAST_EXISTS: !P l l'. @@ -225,101 +166,6 @@ qexists_tac `i` >> fs [] QED -(* Note: Since l can have duplicate elements, we need to make sure - * EL i l is the FIRST encounter of HD l' in l. *) -Theorem FILTER_BEFORE: - !P l l' i. - FILTER P l = l' ==> - LENGTH l' > 0 ==> - (OLEAST i. oEL i l = SOME (HD l')) = SOME i ==> - (!i'. i' < i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') -Proof -rpt strip_tac >| [ - subgoal `MEM (EL i' l) l` >- ( - irule rich_listTheory.EL_MEM >> - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] - ) >> - subgoal `MEM (EL i' l) l'` >- ( - metis_tac [listTheory.MEM_FILTER] - ) >> - subgoal `?i''. (OLEAST i. oEL i l = SOME (EL i' l)) = SOME i''` >- ( - metis_tac [MEM_OLEAST] - ) >> - (* Contradictions after case analysis of i'' vs. i' and i *) - imp_res_tac FILTER_HD_OLEAST >> - Cases_on `i'' = i'` >- ( - fs [] - ) >> - Cases_on `i'' < i'` >- ( - fs [] - ) >> - Cases_on `i'' > i'` >- ( - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> - QSPECL_X_ASSUM ``!i'3'. i'3' < i'' ==> EL i'3' l = EL i' l ==> ~(i'3' < LENGTH l)`` [`i'`] >> - fs [arithmeticTheory.GREATER_DEF] - ) >> - fs [], - - (* Very similar to other case *) - subgoal `MEM (EL i' l) l` >- ( - irule rich_listTheory.EL_MEM >> - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] - ) >> - subgoal `?i''. (OLEAST i. oEL i l = SOME (EL i' l)) = SOME i''` >- ( - metis_tac [MEM_OLEAST] - ) >> - (* Contradictions after case analysis of i'' vs. i' and i *) - imp_res_tac FILTER_HD_OLEAST >> - Cases_on `i'' = i'` >- ( - fs [] - ) >> - Cases_on `i'' < i'` >- ( - fs [] - ) >> - Cases_on `i'' > i'` >- ( - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> - QSPECL_X_ASSUM ``!i'3'. i'3' < i'' ==> EL i'3' l = EL i' l ==> ~(i'3' < LENGTH l)`` [`i'`] >> - fs [arithmeticTheory.GREATER_DEF] - ) >> - fs [] -] -QED - -(* TODO: Since l can have duplicate elements, we need to make sure - * EL i l is the LAST encounter of LAST l' in l. *) -(* TODO: Might require list nonempty or OLEAST... *) -(* TODO: Use EXISTENTIAL quantification for i *) -(* TODO: Use bir_auxiliaryTheory.LAST_FILTER_EL *) -Theorem FILTER_AFTER: - !P l l' i. - FILTER P l = l' ==> - (LEAST i. EL i (REVERSE l) = HD l') = i ==> - (!i'. i' > i ==> ~P (EL i' l) /\ ~MEM (EL i' l) l') -Proof -cheat -QED - -(* TODO: This is just plain wrong... *) -(* TODO: Would it suffice with - * "there exists i', i'' such that i' < i'', EL i' l = EL i (FILTER P l) and - * EL i'' l = EL (SUC i) (FILTER P l)"? *) -Theorem FILTER_ORDER: - !P l i i' i''. - EL i' l = EL i (FILTER P l) ==> - EL i'' l = EL (SUC i) (FILTER P l) ==> - i' < i'' -Proof -cheat -QED -Theorem FILTER_ORDER_alt: - !P l i x x'. - SOME x = oEL i (FILTER P l) ==> - SOME x' = oEL (SUC i) (FILTER P l) ==> - (?i' i''. i' < i'' /\ x = EL i' l /\ x' = EL i'' l /\ (!i'''. i''' > i' /\ i''' < i'' ==> ~P (EL i''' l))) -Proof -cheat -QED - Theorem INDEX_FIND_SUFFIX: !P n i x_list x. i < n ==> @@ -394,6 +240,19 @@ metis_tac [FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] QED +Theorem FUNPOW_OPT_split: +!f n' n s s'' s'. +n > n' ==> +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f (n - n') s = SOME s'' ==> +FUNPOW_OPT f n' s'' = SOME s' +Proof +rpt strip_tac >> +irule FUNPOW_OPT_INTER >> +qexistsl_tac [`s`, `n - n'`] >> +fs [] +QED + (* TODO: Use FUNPOW_OPT_next_n_NONE instead of this *) Theorem FUNPOW_OPT_ADD_NONE: !f n n' ms ms'. @@ -437,1080 +296,32 @@ rpt strip_tac >> metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] QED - -(*******************) -(* FUNPOW_OPT_LIST *) -(*******************) - -(* Head-recursive version (nicer for most proofs) *) -Definition FUNPOW_OPT_LIST_def: - (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ - (FUNPOW_OPT_LIST f (SUC n) s = - case FUNPOW_OPT_LIST f n s of - | SOME res_prefix => - (case f (LAST res_prefix) of - | SOME res_last => SOME (SNOC res_last res_prefix) - | NONE => NONE) - | NONE => NONE) -End - -Theorem FUNPOW_OPT_LIST_HD: - !f n s l. - FUNPOW_OPT_LIST f n s = SOME l ==> - ?l'. FUNPOW_OPT_LIST f n s = SOME (s::l') -Proof -cheat -QED - -Theorem FUNPOW_OPT_LIST_SUC_NONE: - !f n s l. - FUNPOW_OPT_LIST f n s = SOME l ==> - f (LAST l) = NONE ==> - FUNPOW_OPT f (SUC n) s = NONE -Proof -rpt strip_tac >> -fs [arithmeticTheory.ADD1] >> -ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> -irule FUNPOW_OPT_ADD_NONE >> -qexists_tac `LAST l` >> -fs [FUNPOW_OPT_compute] >> -cheat -QED - -Theorem FUNPOW_OPT_LIST_SUC_SOME: - !f n s l x. - FUNPOW_OPT_LIST f n s = SOME l ==> - f (LAST l) = SOME x ==> - FUNPOW_OPT f (SUC n) s = SOME x -Proof -cheat -QED - -Theorem FUNPOW_OPT_LIST_NEQ_NONE_PREV: - !f n s l. - FUNPOW_OPT_LIST f n s = SOME l ==> - !n'. n' <= n ==> FUNPOW_OPT f n' s <> NONE -Proof -cheat -QED - -(* TODO: Split up in two theorems, one specific for FUNPOW_OPT equivalence? *) -Theorem FUNPOW_OPT_LIST_EQ_SOME: - !f n s l. - FUNPOW_OPT_LIST f n s = SOME l <=> - LENGTH l = (SUC n) /\ - FUNPOW_OPT f n s = SOME (LAST l) /\ - (!n'. n' <= n ==> FUNPOW_OPT f n' s = SOME (EL n' l)) /\ - !i. (SUC i) < LENGTH l ==> - f (EL i l) = SOME (EL (SUC i) l) -Proof -rpt strip_tac >> -EQ_TAC >| [ - (* TODO: Lemmatize *) - rpt strip_tac >| [ - cheat, - - cheat, - - (* TODO: Use FUNPOW_OPT_LIST_NEQ_NONE_PREV *) - cheat, - - cheat - ], - - cheat -] -QED - -Theorem FUNPOW_OPT_LIST_EQ_NONE: - !f n s. - FUNPOW_OPT_LIST f n s = NONE <=> - ?n'. n' <= n /\ FUNPOW_OPT f n' s = NONE /\ - (* TODO: Overkill? What is needed on LHS? *) - (!n''. n'' < n' ==> (FUNPOW_OPT f n'' s <> NONE)) -Proof -rpt strip_tac >> -EQ_TAC >| [ - rpt strip_tac >> - Induct_on `n` >- ( - rpt strip_tac >> - qexists_tac `0` >> - fs [FUNPOW_OPT_LIST_def] - ) >> - rpt strip_tac >> - fs [FUNPOW_OPT_LIST_def] >> - Cases_on `FUNPOW_OPT_LIST f n s` >> ( - fs [] - ) >| [ - qexists_tac `n'` >> - fs [], - - Cases_on `f (LAST x)` >> ( - fs [] - ) >> - qexists_tac `SUC n` >> - fs [] >> - CONJ_TAC >| [ - (* Looks OK, might be a lemma *) - metis_tac [FUNPOW_OPT_LIST_SUC_NONE], - - (* Should follow from FUNPOW_OPT_LIST_EQ_SOME - break out to separate lemma? *) - rpt strip_tac >> - IMP_RES_TAC FUNPOW_OPT_LIST_NEQ_NONE_PREV >> - QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT f n' s <> NONE`` [`n''`] >> - rfs [] - ] - ], - - rpt strip_tac >> - fs [FUNPOW_OPT_LIST_def] >> - Induct_on `n` >| [ - rpt strip_tac >> - fs [FUNPOW_OPT_def], - - rpt strip_tac >> - fs [FUNPOW_OPT_LIST_def] >> - Cases_on `n' = SUC n` >- ( - fs [] >> - Cases_on `FUNPOW_OPT_LIST f n s` >> ( - fs [] - ) >> - Cases_on `f (LAST x)` >> ( - fs [] - ) >> - fs [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_SUC_SOME >> - fs [] - ) >> - fs [] - ] -] -QED - -(* Tail-recursive evaluation of FUNPOW_OPT_LIST *) -Theorem FUNPOW_OPT_LIST_tail: - !f n s l. - (FUNPOW_OPT_LIST f 0 s = SOME [s]) /\ - (FUNPOW_OPT_LIST f (SUC n) s = - case f s of - | SOME res_head => - (case FUNPOW_OPT_LIST f n res_head of - | SOME res_tail => SOME (s::res_tail) - | NONE => NONE) - | NONE => NONE) -Proof -rpt strip_tac >| [ - fs [FUNPOW_OPT_LIST_def], - - Cases_on `f s` >| [ - fs [FUNPOW_OPT_LIST_EQ_NONE] >> - qexists_tac `1` >> - fs [FUNPOW_OPT_compute] >> - rpt strip_tac >> - Cases_on `n''` >> ( - fs [FUNPOW_OPT_compute] - ), - - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - Induct_on `n` >> ( - fs [FUNPOW_OPT_LIST_def] - ) >> - Cases_on `FUNPOW_OPT_LIST f n x` >- ( - fs [FUNPOW_OPT_LIST_def] - ) >> - Cases_on `x'` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] - ) >> - Cases_on `f (LAST (h::t))` >> ( - fs [] - ) >> - fs [listTheory.LAST_compute] - ] -] -QED - -Theorem FUNPOW_OPT_LIST_NONEMPTY: - !f n x l. - FUNPOW_OPT_LIST f n x = SOME l ==> - l <> [] -Proof -rpt strip_tac >> -rw [] >> -Cases_on `n` >> ( - fs [FUNPOW_OPT_LIST_def] -) >> -Cases_on `FUNPOW_OPT_LIST f n' x` >> ( - fs [] -) >> -Cases_on `f (LAST x')` >> ( - fs [] -) -QED - -Theorem FUNPOW_OPT_LIST_LAST: - !f n x l_opt. - FUNPOW_OPT_LIST f n x = l_opt ==> - (case l_opt of - | SOME l => - FUNPOW_OPT f n x = SOME (LAST l) - | NONE => FUNPOW_OPT f n x = NONE) -Proof -rpt strip_tac >> -Cases_on `l_opt` >| [ - fs [FUNPOW_OPT_LIST_EQ_NONE] >> - subgoal `?n''. n = n' + n''` >- ( - qexists_tac `n - n'` >> - fs [] - ) >> - metis_tac [FUNPOW_OPT_next_n_NONE], - - fs [FUNPOW_OPT_LIST_EQ_SOME] -] -QED - -Theorem FUNPOW_OPT_LIST_NONE: - !f n x. - FUNPOW_OPT_LIST f n x = NONE ==> - FUNPOW_OPT_LIST f (SUC n) x = NONE -Proof -fs [FUNPOW_OPT_LIST_def] -QED - -(* -Theorem FUNPOW_OPT_LIST_CONS: - !f x n t. - FUNPOW_OPT_LIST f n x = SOME t ==> - ((?h. f (LAST t) = SOME h /\ - FUNPOW_OPT_LIST f (SUC n) x = SOME (SNOC h t)) \/ FUNPOW_OPT_LIST f (SUC n) x = NONE) +(* TODO: Relax the first OLEAST? *) +Theorem FUNPOW_OPT_cycle: + !f s s' n n'. + (OLEAST n. n > 0 /\ FUNPOW_OPT f n s = SOME s) = SOME n ==> + s <> s' ==> + (OLEAST n'. FUNPOW_OPT f n' s = SOME s') = SOME n' ==> + n' < n Proof rpt strip_tac >> -Cases_on `n` >> ( - fs [FUNPOW_OPT_LIST_def] -) >| [ - rw [] >> - Cases_on `f x` >> ( - fs [] - ), - - Cases_on `FUNPOW_OPT_LIST f n' x` >> ( - fs [] - ) >> - Cases_on `f (LAST x')` >> ( - fs [] - ) >> - Cases_on `f (LAST t)` >> ( - fs [] - ) -] -QED -*) - -Theorem FUNPOW_OPT_LIST_FRONT_PRE: - !f x n t. - FUNPOW_OPT_LIST f (SUC n) x = SOME t ==> - FUNPOW_OPT_LIST f n x = SOME (FRONT t) -Proof -rpt strip_tac >> -fs [FUNPOW_OPT_LIST_def] >> -Cases_on `FUNPOW_OPT_LIST f n x` >> ( - fs [] -) >> -Cases_on `f (LAST x')` >> ( - fs [] -) >> -rw [listTheory.FRONT_DEF] >> -fs [rich_listTheory.FRONT_APPEND] -QED - -Theorem FUNPOW_OPT_LIST_BACK_PRE: - !f x x' n l. - FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> - f x = SOME x' ==> - FUNPOW_OPT_LIST f n x' = SOME (TL l) -Proof -rpt strip_tac >> -fs [FUNPOW_OPT_LIST_tail] >> -Cases_on `FUNPOW_OPT_LIST f n x'` >> ( - fs [] -) >> -rw [] -QED - -Theorem FUNPOW_OPT_LIST_BACK_INCR: - !f x x' n t. - FUNPOW_OPT_LIST f n x' = SOME t ==> - f x = SOME x' ==> - FUNPOW_OPT_LIST f (SUC n) x = SOME (x::t) -Proof -rpt strip_tac >> -fs [FUNPOW_OPT_LIST_tail] -QED - -Theorem FUNPOW_OPT_LIST_LENGTH: - !n l f x. - FUNPOW_OPT_LIST f n x = SOME l ==> - LENGTH l = (SUC n) -Proof -Induct_on `n` >- ( - fs [FUNPOW_OPT_LIST_def] -) >> -rpt strip_tac >> -subgoal `FUNPOW_OPT_LIST f n x = SOME (FRONT l)` >- ( - metis_tac [FUNPOW_OPT_LIST_FRONT_PRE] -) >> -RES_TAC >> -IMP_RES_TAC FUNPOW_OPT_LIST_NONEMPTY >> -IMP_RES_TAC rich_listTheory.LENGTH_FRONT >> -fs [] -QED - -Theorem FUNPOW_OPT_SUBLIST: - !f n n' x l. - n' <= n ==> - FUNPOW_OPT_LIST f (SUC n) x = SOME l ==> - FUNPOW_OPT_LIST f (SUC n − n') (LAST (TAKE (SUC n') l)) = SOME (DROP n' l) ==> - FUNPOW_OPT_LIST f (n − n') (LAST (TAKE (SUC (SUC n')) l)) = SOME (DROP (SUC n') l) -Proof -rpt strip_tac >> -fs [FUNPOW_OPT_LIST_EQ_SOME] >> -rpt strip_tac >| [ - (* OK: starting one step later but taking one step less leads to same end result *) - irule FUNPOW_OPT_step >> - qexists_tac `LAST (TAKE (SUC n') l)` >> - fs [] >> - strip_tac >| [ - QSPECL_X_ASSUM ``!i. SUC i < LENGTH l ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> - rfs [] >> - `EL n' l = LAST (TAKE (SUC n') l) /\ EL (SUC n') l = LAST (TAKE (SUC (SUC n')) l)` suffices_by ( - rpt strip_tac >> - fs [] >> - rw [] - ) >> - strip_tac >> ( - irule LAST_TAKE_EL >> - fs [] - ), - - subgoal `EL (SUC n - n') (DROP n' l) = EL (SUC (n - n')) (DROP n' l)` >- ( - fs [arithmeticTheory.SUB_LEFT_SUC] >> - Cases_on `n = n'` >> ( - fs [] - ) - ) >> - fs [listTheory.last_drop] - ], - - (* OK: starting one step later, and then taking steps that won't let you reach the end of l - * makes you reach the associated index of l *) - irule FUNPOW_OPT_INTER >> - qexists_tac `x` >> - qexists_tac `SUC n'` >> - rfs [] >> - strip_tac >| [ - irule LAST_TAKE_EL >> - fs [], - - ONCE_REWRITE_TAC [EQ_SYM_EQ] >> - irule listTheory.EL_DROP >> - fs [] - ], - - (* OK: Property should hold for element i of sublist starting from element SUC n' *) - QSPECL_X_ASSUM ``!i. SUC i < LENGTH l - n' ==> - f (EL i (DROP n' l)) = SOME (EL (SUC i) (DROP n' l))`` [`SUC i`] >> - rfs [] >> - subgoal `EL (SUC i) (DROP n' l) = EL i (DROP (SUC n') l)` >- ( - fs [rich_listTheory.DROP_CONS_EL] - ) >> - subgoal `EL (SUC (SUC i)) (DROP n' l) = EL (SUC i) (DROP (SUC n') l)` >- ( - fs [rich_listTheory.DROP_CONS_EL] - ) >> - fs [] -] -QED - -Theorem FUNPOW_OPT_LIST_APPEND: - !f n n' x l. - n' <= n ==> - FUNPOW_OPT_LIST f n x = SOME l ==> - ?l' l''. - FUNPOW_OPT_LIST f n' x = SOME l' /\ - FUNPOW_OPT_LIST f (n - n') (LAST l') = SOME l'' /\ - l' ++ (DROP 1 l'') = l -Proof -rpt strip_tac >> -qexists_tac `TAKE (SUC n') l` >> -qexists_tac `DROP n' l` >> -rpt strip_tac >| [ - Induct_on `n'` >- ( - strip_tac >> - Cases_on `n` >- ( - fs [FUNPOW_OPT_LIST_def] >> - rw [] - ) >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - Cases_on `l` >> ( - fs [] - ) - ) >> - rpt strip_tac >> - Q.SUBGOAL_THEN `n' ≤ n` (fn thm => fs [thm]) >- ( - fs [] - ) >> - fs [FUNPOW_OPT_LIST_def] >> - Cases_on `f (LAST (TAKE (SUC n') l))` >- ( - fs [] >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - QSPECL_X_ASSUM ``!n'. - n' <= n ==> - FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> - rfs [] >> - QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> - rfs [] >> - Q.SUBGOAL_THEN `LAST (TAKE (SUC n') l) = EL n' l` (fn thm => fs [thm]) >- ( - fs [] - ) - ) >> - fs [] >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - subgoal `x' = EL (SUC n') l` >- ( - QSPECL_X_ASSUM ``!n'. - n' <= n ==> - FUNPOW_OPT f n' x = SOME (EL n' l)`` [`n'`] >> - rfs [] >> - QSPECL_X_ASSUM ``!i. i < n ==> f (EL i l) = SOME (EL (SUC i) l)`` [`n'`] >> - rfs [] >> - `LAST (TAKE (SUC n') l) = EL n' l` suffices_by ( - rpt strip_tac >> - fs [] - ) >> - ONCE_REWRITE_TAC [EQ_SYM_EQ] >> - irule LAST_TAKE_EL >> - fs [] - ) >> - rw [] >> - Q.SUBGOAL_THEN `TAKE (SUC (SUC n')) l = TAKE (SUC n') l ++ TAKE 1 (DROP (SUC n') l)` (fn thm => fs [thm]) >- ( - Q.SUBGOAL_THEN `(SUC (SUC n')) = (SUC n') + 1` (fn thm => fs [thm]) >- ( - fs [arithmeticTheory.ADD1] - ) >> - fs [listTheory.TAKE_SUM] - ) >> - fs [listTheory.TAKE1_DROP], - - (* Start off after n' steps, take n - n' steps *) - Induct_on `n'` >- ( - strip_tac >> - fs [] >> - Q.SUBGOAL_THEN `TAKE 1 l = [x]` (fn thm => fs [thm]) >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - Cases_on `n` >- ( - fs [FUNPOW_OPT_def] >> - subgoal `l <> []` >- ( - Cases_on `l` >> ( - fs [] - ) - ) >> - fs [listTheory.TAKE1] - ) >> - QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT f n'' x = SOME (EL n'' l)`` [`0`] >> - fs [FUNPOW_OPT_def] >> - subgoal `l <> []` >- ( - Cases_on `l` >> ( - fs [] - ) - ) >> - fs [listTheory.TAKE1] - ) - ) >> - Cases_on `n` >- ( - fs [] - ) >> - rpt strip_tac >> - Q.SUBGOAL_THEN `n' ≤ SUC n''` (fn thm => fs [thm]) >- ( - fs [] - ) >> - (* If you take one more step, if you start one step earlier, then the result is the same as before - * with one less step dropped (from head) *) - irule FUNPOW_OPT_SUBLIST >> - fs [] >> - qexists_tac `x` >> - fs [], - - fs [rich_listTheory.DROP_DROP_T, arithmeticTheory.ADD1] -] -QED - -Theorem FUNPOW_OPT_LIST_EL_SOME: - !f n n' x l. - FUNPOW_OPT_LIST f n x = SOME l ==> - n' <= n ==> - ?x'. FUNPOW_OPT f n' x = SOME x' -Proof -rpt strip_tac >> -IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> -qexists_tac `LAST l'` >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] -QED - -Theorem FUNPOW_OPT_LIST_EL_NONE: - !f n n' x. - FUNPOW_OPT_LIST f n x = NONE ==> - (n' >= n) ==> - FUNPOW_OPT f n' x = NONE -Proof -rpt strip_tac >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] >> -subgoal `?n''. n' = n + n''` >- ( - fs [arithmeticTheory.LESS_EQUAL_ADD] -) >> -metis_tac [FUNPOW_OPT_next_n_NONE] -QED - -Theorem FUNPOW_OPT_LIST_EL_NEXT: - !f n x x'. - FUNPOW_OPT_LIST f n x = SOME x' ==> - FUNPOW_OPT f (SUC n) x = f (LAST x') -Proof -rpt strip_tac >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] >> -Cases_on `f (LAST x')` >| [ - fs [arithmeticTheory.ADD1] >> - ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> - irule FUNPOW_OPT_ADD_NONE >> - qexists_tac `LAST x'` >> - fs [FUNPOW_OPT_compute], - - fs [arithmeticTheory.ADD1] >> - ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> - irule FUNPOW_OPT_ADD_thm >> - qexists_tac `LAST x'` >> - fs [FUNPOW_OPT_compute] -] -QED - -Theorem FUNPOW_OPT_LIST_EXISTS: - !f n n' x x'. - FUNPOW_OPT f n x = SOME x' ==> - n' <= n ==> - ?l. FUNPOW_OPT_LIST f n' x = SOME l -Proof -Induct_on `n` >- ( - rpt strip_tac >> - qexists_tac `[x']` >> - fs [] >> - rw [] >> - fs [FUNPOW_OPT_LIST_def, FUNPOW_OPT_def] -) >> -rpt strip_tac >> -Cases_on `n' = SUC n` >- ( - fs [FUNPOW_OPT_LIST_def] >> - Cases_on `FUNPOW_OPT_LIST f n x` >- ( - fs [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_NONE >> - subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( - irule FUNPOW_OPT_prev_EXISTS >> - qexists_tac `SUC n` >> - qexists_tac `x'` >> - fs [] - ) >> - IMP_RES_TAC (Q.SPECL [`f`, `n`, `SUC n`, `x`] FUNPOW_OPT_LIST_EL_NONE) >> - fs [] - ) >> - Cases_on `f (LAST x'')` >- ( - fs [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_EL_NEXT >> - fs [] - ) >> - fs [] -) >> -subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( - irule FUNPOW_OPT_prev_EXISTS >> - qexists_tac `SUC n` >> - qexists_tac `x'` >> - fs [] -) >> -QSPECL_X_ASSUM ``!f n' x x'. _`` [`f`, `n'`, `x`, `x''`] >> -fs [] -QED - -Theorem FUNPOW_OPT_LIST_EXISTS_nicer: - !f n n' x x'. - FUNPOW_OPT f n x = SOME x' ==> - n' <= n ==> - ?l. FUNPOW_OPT_LIST f n' x = SOME (x::l) -Proof -rpt strip_tac >> -IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS >> -Cases_on `n'` >> Cases_on `l` >| [ - fs [FUNPOW_OPT_LIST_def], - - fs [FUNPOW_OPT_LIST_def], - - fs [FUNPOW_OPT_LIST_tail] >> - Cases_on `f x` >> ( - fs [] - ) >> - Cases_on `FUNPOW_OPT_LIST f n'' x''` >> ( - fs [] - ), - - qexists_tac `t` >> - fs [FUNPOW_OPT_LIST_tail] >> - Cases_on `f x` >> ( - fs [] - ) >> - Cases_on `FUNPOW_OPT_LIST f n'' x''` >> ( - fs [] - ) -] -QED - -Theorem FUNPOW_OPT_LIST_EXISTS_exact: - !f n x x'. - FUNPOW_OPT f n x = SOME x' ==> - n > 0 ==> - ?l. FUNPOW_OPT_LIST f n x = SOME (x::(SNOC x' l)) -Proof -rpt strip_tac >> -IMP_RES_TAC FUNPOW_OPT_LIST_EXISTS_nicer >> -QSPECL_X_ASSUM ``!n'. n' <= n ==> ?l. FUNPOW_OPT_LIST f n' x = SOME (x::l)`` [`n`] >> -fs [] >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [listTheory.LAST_DEF] >> -Cases_on `l = []` >> ( - fs [] -) >| [ - imp_res_tac FUNPOW_OPT_LIST_LENGTH >> - fs [], - - qexists_tac `FRONT l` >> - rw [] >> - metis_tac [listTheory.APPEND_FRONT_LAST] -] -QED - -Theorem FUNPOW_OPT_LIST_EL: - !f n n' x x' l. - FUNPOW_OPT_LIST f n x = SOME l ==> - n' <= n ==> - FUNPOW_OPT f n' x = SOME x' ==> - (EL n' l) = x' -Proof -rpt strip_tac >> -IMP_RES_TAC (Q.SPECL [`f`, `n`, `n'`, `x`, `l`] FUNPOW_OPT_LIST_APPEND) >> -subgoal `EL n' l = LAST l'` >- ( - rw [] >> - IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> - Q.SUBGOAL_THEN `n' = PRE (LENGTH l')` (fn thm => REWRITE_TAC [thm]) >- ( - fs [] - ) >> - Q.SUBGOAL_THEN `EL (PRE (LENGTH l')) (l' ++ DROP 1 l'') = EL (PRE (LENGTH l')) l'` (fn thm => REWRITE_TAC [thm]) >- ( - irule rich_listTheory.EL_APPEND1 >> - fs [] - ) >> - irule rich_listTheory.EL_PRE_LENGTH >> - Cases_on `l'` >> ( - fs [] - ) -) >> -IMP_RES_TAC FUNPOW_OPT_LIST_LAST >> -fs [] -QED - -(* -Theorem FUNPOW_OPT_LIST_INDEX_FIND: - !f P n x l i x'. - FUNPOW_OPT_LIST f n x = SOME l ==> - INDEX_FIND 0 P l = SOME (i, x') ==> - FUNPOW_OPT f i x = SOME x' -Proof -rpt strip_tac >> -fs [INDEX_FIND_EQ_SOME_0] >> -IMP_RES_TAC (Q.SPECL [`f`, `n`, `i`, `x`, `l`] FUNPOW_OPT_LIST_EL_SOME) >> -QSPECL_X_ASSUM ``!i. _`` [`i`] >> -IMP_RES_TAC FUNPOW_OPT_LIST_LENGTH >> -rfs [] >> -fs [] >> -rfs [] >> -IMP_RES_TAC (Q.SPECL [`f`, `n`, `x`, `l`] FUNPOW_OPT_LIST_EQ_SOME) >> -QSPECL_X_ASSUM ``!n'. n' <= n ==> FUNPOW_OPT f n' x = SOME (EL n' l)`` [`i`] >> -rfs [] -QED -*) - -Theorem FUNPOW_OPT_LIST_FIRST: - !f n x x' x_list. - n > 0 ==> - FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> - f x = SOME x' ==> - FUNPOW_OPT_LIST f (PRE n) x' = SOME x_list -Proof -rpt strip_tac >> -Cases_on `n` >- ( - fs [] -) >> -fs [FUNPOW_OPT_LIST_EQ_SOME, FUNPOW_OPT_REWRS] >> -rpt CONJ_TAC >| [ - QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT f n'' x = SOME (EL n'' (x::x_list))`` [`SUC n'`] >> - Cases_on `x_list` >- ( - fs [] - ) >> - fs [listTheory.LAST_CONS], - - rpt strip_tac >> - QSPECL_X_ASSUM ``!n''. n'' <= SUC n' ==> FUNPOW_OPT f n'' x = SOME (EL n'' (x::x_list))`` [`SUC n''`] >> - rfs [FUNPOW_OPT_REWRS], - - rpt strip_tac >> - QSPECL_X_ASSUM ``!i. i < LENGTH x_list ==> f (EL i (x::x_list)) = SOME (EL i x_list)`` [`SUC i`] >> - fs [] -] -QED - -Theorem FUNPOW_OPT_LIST_PRE: - !f n x x' x_list. - n > 0 ==> - FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> - f x = SOME x' ==> - FUNPOW_OPT_LIST f (PRE n) x' = SOME x_list -Proof -rpt strip_tac >> -Cases_on `n` >> ( - fs [FUNPOW_OPT_LIST_tail] +CCONTR_TAC >> +Cases_on `n' = n` >- ( + fs [whileTheory.OLEAST_EQ_SOME] ) >> -Cases_on `FUNPOW_OPT_LIST f n' x'` >> ( - fs [] -) -QED - -(* TODO: Rename to FUNPOW_OPT_LIST_DROP? *) -Theorem FUNPOW_OPT_LIST_SUFFIX: -!f n i x x_list. -SUC i <= n ==> -FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> -FUNPOW_OPT_LIST f (n - SUC i) (EL i x_list) = SOME (EL i x_list::DROP (SUC i) x_list) -Proof -rpt strip_tac >> -imp_res_tac FUNPOW_OPT_LIST_APPEND >> -subgoal `EL i x_list = LAST l'` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] >> +subgoal `n' > n` >- ( gs [] ) >> -fs [FUNPOW_OPT_LIST_tail] >> -Cases_on `f x` >> ( - fs [] -) >> -Cases_on `FUNPOW_OPT_LIST f i x'` >> ( - fs [] -) >> -qpat_x_assum `x::x'' = l'` (fn thm => fs [GSYM thm]) >> -qpat_x_assum `x'' ++ DROP 1 l'' = x_list` (fn thm => fs [GSYM thm]) >> -subgoal `LENGTH x'' = SUC i` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] -) >> -Q.SUBGOAL_THEN `DROP (SUC i) (x'' ++ DROP 1 l'') = (DROP (SUC i) x'') ++ DROP 1 l''` - (fn thm => fs [thm]) >- ( - irule rich_listTheory.DROP_APPEND1 >> +subgoal `FUNPOW_OPT f (n' - n) s = SOME s'` >- ( + irule FUNPOW_OPT_split2 >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `s` >> fs [] ) >> -fs [listTheory.DROP_LENGTH_TOO_LONG] >> -Cases_on `l''` >- ( - fs [FUNPOW_OPT_LIST_EQ_SOME] -) >> -imp_res_tac FUNPOW_OPT_LIST_HD >> +fs [whileTheory.OLEAST_EQ_SOME] >> +QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT f n'' s <> SOME s'`` [`n' - n`] >> gs [] QED -(* -val FUNPOW_OPT_todoname = prove(`` -!f n n' n'' P ms ms_list. -FUNPOW_OPT_LIST f n ms = SOME (ms::ms_list) ==> -FUNPOW_OPT f n'' ms = - SOME - (EL (LENGTH (FILTER P ms_list) - 1) - (FILTER P ms_list)) ==> -n' < n - n'' ==> -FUNPOW_OPT f (n' + n'') ms = SOME (EL (PRE (n' + n'')) ms_list)``, - -rpt strip_tac >> -fs [FUNPOW_OPT_LIST_EQ_SOME] >> -irule rich_listTheory.EL_CONS >> -(* TODO: Likely not provable... *) -cheat -); -*) - -(* For weak_rel_steps_list_states_subgoal_2_lemma *) -Theorem FUNPOW_OPT_LIST_FILTER_NULL: -!f n x x' x_list P P'. - n > 0 ==> - FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> - INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> - FILTER P' x_list = [] ==> - INDEX_FIND 0 (\x. P x \/ P' x) x_list = SOME (PRE n,x') -Proof -rpt strip_tac >> -subgoal `?x''. FUNPOW_OPT f n x = SOME x''` >- ( - irule FUNPOW_OPT_LIST_EL_SOME >> - qexists_tac `x::x_list` >> - qexists_tac `n` >> - fs [] -) >> -fs [listTheory.FILTER_EQ_NIL] >> -subgoal `EL (PRE n) x_list = x''` >- ( - subgoal `(EL n (x::x_list)) = x''` >- ( - irule FUNPOW_OPT_LIST_EL >> - qexists_tac `f` >> - qexists_tac `n` >> - qexists_tac `x` >> - fs [] - ) >> - metis_tac [rich_listTheory.EL_CONS, arithmeticTheory.GREATER_DEF] -) >> -fs [INDEX_FIND_EQ_SOME_0, listTheory.EVERY_EL] -QED - -Theorem FUNPOW_OPT_LIST_PREFIX: -!f n n' i x x_list x_list'. - FUNPOW_OPT_LIST f n x = SOME x_list ==> - FUNPOW_OPT_LIST f n' x = SOME x_list' ==> - n' <= n ==> - x_list' <<= x_list -Proof -rpt strip_tac >> -fs [rich_listTheory.IS_PREFIX_APPEND] >> -IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> -qexists_tac `DROP 1 l''` >> -rw [] >> -fs [] -QED - -Theorem FUNPOW_OPT_LIST_EL_EQ: -!f n n' i x x_list x_list'. - FUNPOW_OPT_LIST f n x = SOME x_list ==> - FUNPOW_OPT_LIST f n' x = SOME x_list' ==> - n' < n ==> - i <= n' ==> - EL i x_list' = EL i x_list -Proof -rpt strip_tac >> -irule rich_listTheory.is_prefix_el >> -rpt strip_tac >| [ - fs [FUNPOW_OPT_LIST_EQ_SOME], - - fs [FUNPOW_OPT_LIST_EQ_SOME], - - irule FUNPOW_OPT_LIST_PREFIX >> - qexists_tac `f` >> - qexists_tac `n` >> - qexists_tac `n'` >> - qexists_tac `x` >> - fs [] -] -QED - -Theorem FUNPOW_OPT_LIST_FILTER_FIRST: -!f n x x' x_list P P'. - FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> - INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> - LENGTH (FILTER P' x_list) > 0 ==> - ~P' (LAST x_list) ==> - ?n'. - (n' > 0 /\ - ?x_list'. - FUNPOW_OPT_LIST f n' x = SOME (x::x_list') /\ - INDEX_FIND 0 (\x''. P' x'' \/ P x'') x_list' = SOME (PRE n', HD (FILTER P' x_list))) /\ - (n > n' /\ - ?x_list'. - FUNPOW_OPT_LIST f (n - n') - (HD (FILTER P' x_list)) = - SOME (HD (FILTER P' x_list)::x_list') /\ - INDEX_FIND 0 P x_list' = SOME (PRE (n - n'), x')) /\ n' < n /\ n' > 0 -Proof -rpt strip_tac >> -subgoal `?x''. x'' = EL 0 (FILTER P' x_list)` >- ( - metis_tac [] -) >> -subgoal `?x_list'. FILTER P' x_list = x_list'` >- ( - fs [] -) >> -subgoal `LENGTH x_list > 0` >- ( - fs [INDEX_FIND_EQ_SOME_0] -) >> -subgoal `?i. (OLEAST i. oEL i x_list = SOME x'') = SOME i /\ i < (PRE n)` >- ( - IMP_RES_TAC FILTER_HD_OLEAST_EXISTS >> - gs [] >> - fs [whileTheory.OLEAST_EQ_SOME] >> - - Cases_on `i = PRE n` >- ( - subgoal `P' x''` >- ( - IMP_RES_TAC FILTER_MEM >> - QSPECL_X_ASSUM ``!x. MEM x x_list' ==> P' x`` [`x''`] >> - PAT_ASSUM ``x'' = HD x_list'`` (fn thm => fs [thm]) >> - Q.SUBGOAL_THEN `MEM (HD x_list') x_list'` (fn thm => rfs [thm]) >- ( - rfs [MEM_HD, listTheory.NOT_NIL_EQ_LENGTH_NOT_0] - ) - ) >> - subgoal `LAST x_list = x'` >- ( - fs [INDEX_FIND_EQ_SOME_0] >> - fs [FUNPOW_OPT_LIST_EQ_SOME] >> - subgoal `x_list <> []` >- ( - Cases_on `x_list` >> ( - fs [] - ) - ) >> - metis_tac [listTheory.LAST_EL] - ) >> - subgoal `x'' = x'` >- ( - fs [listTheory.oEL_THM, INDEX_FIND_EQ_SOME_0] - ) >> - rw [] >> - fs [] - ) >> - fs [FUNPOW_OPT_LIST_EQ_SOME, listTheory.oEL_THM] -) >> -qexists_tac `SUC i` >> -fs [] >> -rpt strip_tac >| [ - (* subgoal 3a. OK: SUC i steps taken until first encounter of l - * EL i ms_list = HD ms_list' is among assumptions *) - subgoal `?x_list''. FUNPOW_OPT_LIST f (SUC i) x = SOME (x::x_list'')` >- ( - subgoal `SUC i <= n` >- ( - fs [] - ) >> - IMP_RES_TAC FUNPOW_OPT_LIST_APPEND >> - fs [] >> - qexists_tac `TL l'` >> - subgoal `x = HD l'` >- ( - Cases_on `l'` >> ( - fs [FUNPOW_OPT_LIST_EQ_SOME] - ) - ) >> - subgoal `~NULL l'` >- ( - Cases_on `l'` >> ( - fs [FUNPOW_OPT_LIST_EQ_SOME] - ) - ) >> - metis_tac [listTheory.CONS] - ) >> - qexists_tac `x_list''` >> - fs [] >> - REWRITE_TAC [INDEX_FIND_EQ_SOME_0] >> - rpt strip_tac >| [ - fs [FUNPOW_OPT_LIST_EQ_SOME], - - fs [whileTheory.OLEAST_EQ_SOME] >> - subgoal `EL i x_list'' = EL i x_list` >- ( - irule EL_PRE_CONS_EQ >> - qexists_tac `x` >> - irule FUNPOW_OPT_LIST_EL_EQ >> - qexists_tac `f` >> - qexists_tac `n` >> - qexists_tac `SUC i` >> - qexists_tac `x` >> - fs [] - ) >> - fs [listTheory.oEL_THM], - - subgoal `MEM (HD x_list') (FILTER P' x_list)` >- ( - rw [] >> - irule MEM_HD >> - Cases_on `FILTER P' x_list` >> ( - fs [] - ) - ) >> - fs [listTheory.MEM_FILTER], - - (* Before first element in filter list, neither P' nor P holds *) - (* P': by FILTER_BEFORE *) - (* P: by INDEX_FIND 0 P x_list = SOME (PRE n,x') *) - fs [] >| [ - IMP_RES_TAC FILTER_BEFORE >> - QSPECL_X_ASSUM ``!i. (OLEAST i. oEL i x_list = SOME (HD x_list')) = SOME i ==> !i'. i' < i ==> ~P' (EL i' x_list)`` [`i`] >> - gs [] >> - QSPECL_X_ASSUM ``!i'. i' < i ==> ~P' (EL i' x_list)`` [`j'`] >> - rfs [] >> - `EL j' x_list'' = EL j' x_list` suffices_by ( - metis_tac [] - ) >> - irule EL_PRE_CONS_EQ >> - qexists_tac `x` >> - irule FUNPOW_OPT_LIST_EL_EQ >> - qexists_tac `f` >> - qexists_tac `n` >> - qexists_tac `SUC i` >> - qexists_tac `x` >> - fs [], - - fs [INDEX_FIND_EQ_SOME_0] >> - QSPECL_X_ASSUM ``!j'. j' < PRE n ==> ~P (EL j' x_list)`` [`j'`] >> - rfs [] >> - `EL j' x_list'' = EL j' x_list` suffices_by ( - metis_tac [] - ) >> - irule EL_PRE_CONS_EQ >> - qexists_tac `x` >> - irule FUNPOW_OPT_LIST_EL_EQ >> - qexists_tac `f` >> - qexists_tac `n` >> - qexists_tac `SUC i` >> - qexists_tac `x` >> - fs [] - ] - ], - - (* subgoal 3b. OK: (n - SUC i) steps taken from first encounter of l will get you to ms' *) - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> - qexists_tac `DROP (SUC i) x_list` >> - rpt strip_tac >| [ - subgoal `SUC i <= n` >- ( - fs [] - ) >> - metis_tac [FUNPOW_OPT_LIST_SUFFIX], - - irule INDEX_FIND_SUFFIX >> - fs [] - ] -] -QED - -Theorem FUNPOW_OPT_LIST_FILTER_LAST: -!f n x x' x_list x_list' P P'. - FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> - INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> - FILTER P' x_list = x_list' ==> - LENGTH x_list' > 0 ==> - ?n'. (?x_list''. - FUNPOW_OPT_LIST f n' (LAST x_list') = - SOME (LAST x_list'::x_list'') /\ - INDEX_FIND 0 (\x''. P' x'' \/ P x'') x_list'' = - SOME (PRE n', x')) /\ n' > 0 -Proof -cheat -QED - -Theorem FUNPOW_OPT_LIST_FILTER_BETWEEN: -!f n x x' x_list x_list' P P' i. - FUNPOW_OPT_LIST f n x = SOME (x::x_list) ==> - INDEX_FIND 0 P x_list = SOME (PRE n,x') ==> - FILTER P' x_list = x_list' ==> - i < (LENGTH x_list') - 1 ==> - ?n' n''. - (?x_list''. - FUNPOW_OPT_LIST f n' (EL i x_list') = - SOME (EL i x_list'::x_list'') /\ - INDEX_FIND 0 (\x''. P' x'' \/ P x'') x_list'' = - SOME (PRE n', EL (i + 1) x_list')) /\ - (?x_list''. - FUNPOW_OPT_LIST f n'' (EL (i + 1) x_list') = - SOME (EL (i + 1) x_list'::x_list'') /\ - INDEX_FIND 0 P x_list'' = SOME (PRE n'', x')) /\ - n' < n /\ n' > 0 /\ n'' < n /\ n'' > 0 -Proof -cheat -QED val _ = export_theory(); diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index c38d856b9..6e6abfd09 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -28,19 +28,6 @@ Definition weak_exec_n_def: (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) End -Theorem FUNPOW_OPT_split: -!f n' n s s'' s'. -n > n' ==> -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f (n - n') s = SOME s'' ==> -FUNPOW_OPT f n' s'' = SOME s' -Proof -rpt strip_tac >> -irule FUNPOW_OPT_INTER >> -qexistsl_tac [`s`, `n - n'`] >> -fs [] -QED - Definition abstract_partial_jgmt_def: abstract_partial_jgmt m (l:'a) (ls:'a->bool) pre post = !ms ms'. @@ -286,7 +273,7 @@ Theorem weak_partial_seq_rule_thm: abstract_partial_jgmt m l ls2 pre post Proof rpt strip_tac >> -SIMP_TAC std_ss [abstract_partial_jgmt_def] >> +simp [abstract_partial_jgmt_def] >> rpt strip_tac >> subgoal `?ms'. m.weak ms (ls1 UNION ls2) ms'` >- ( (* There is at least ms', possibly another state if ls1 is encountered before *) @@ -315,7 +302,7 @@ subgoal `?ls1'. ls1 UNION ls2 = ls1' UNION ls2 /\ DISJOINT ls1' ls2` >- ( fs [] >> subgoal `abstract_jgmt m l (ls1' UNION ls2) (\s. s = ms /\ pre s) (\s. (m.pc s IN ls1' ==> s = ms'') /\ (m.pc s IN ls2 ==> post s))` >- ( fs [abstract_jgmt_def, abstract_partial_jgmt_def] >> - qexists_tac ‘ms''’ >> + qexists_tac `ms''` >> fs [] ) >> subgoal `!l1'. (l1' IN ls1') ==> (abstract_jgmt m l1' ls2 (\s. (m.pc s IN ls1' ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)) (\s. (m.pc s IN ls1' ==> s = ms'') /\ (m.pc s IN ls2 ==> post s)))` >- ( @@ -400,46 +387,6 @@ qexistsl_tac [`SUC n_l`, `ms`] >> fs [arithmeticTheory.ADD1] QED - -Theorem FUNPOW_OPT_cycle: - !f s s' n n'. - (OLEAST n. n > 0 /\ FUNPOW_OPT f n s = SOME s) = SOME n ==> - s <> s' ==> - (OLEAST n'. FUNPOW_OPT f n' s = SOME s') = SOME n' ==> - n' < n -Proof -rpt strip_tac >> -CCONTR_TAC >> -Cases_on `n' = n` >- ( - fs [whileTheory.OLEAST_EQ_SOME] -) >> -subgoal `n' > n` >- ( - gs [] -) >> -subgoal `FUNPOW_OPT f (n' - n) s = SOME s'` >- ( - irule FUNPOW_OPT_split2 >> - fs [whileTheory.OLEAST_EQ_SOME] >> - qexists_tac `s` >> - fs [] -) >> -fs [whileTheory.OLEAST_EQ_SOME] >> -QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT f n'' s <> SOME s'`` [`n' - n`] >> -gs [] -QED - -Theorem weak_exec_n_cycle: - !m s s' ls n_l n_l'. - weak_model m ==> - (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s) = SOME n_l ==> - s <> s' ==> - (OLEAST n_l'. weak_exec_n m s ls n_l' = SOME s') = SOME n_l' ==> - n_l' < n_l -Proof -rpt strip_tac >> -fs [weak_exec_n_def] >> -metis_tac [FUNPOW_OPT_cycle] -QED - (* TODO: Useful? Theorem weak_exec_n_split: !m. weak_model m ==> @@ -473,7 +420,7 @@ metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] QED -Theorem weak_exec_n_cycle_alt: +Theorem weak_exec_n_cycle: !m s s' ls n_l n_l'. weak_model m ==> n_l > 0 /\ weak_exec_n m s ls n_l = SOME s ==> @@ -1097,7 +1044,7 @@ gs [] * needed to reach ms'' *) QED -Theorem weak_exec_uniqueness_alt: +Theorem weak_exec_uniqueness: !m. weak_model m ==> !ms ls ms' ms'' ms''' n_l n_l'. @@ -1169,7 +1116,7 @@ Cases_on `?n_l''. n_l'' > (n_l' + 1) /\ n_l'' < n_l /\ weak_exec_n m ms ls n_l'' ) >> (* By weak_exec_n_cycle *) subgoal `(n_l - (n_l' + 1)) < (n_l'' - (n_l' + 1))` >- ( - irule weak_exec_n_cycle_alt >> + irule weak_exec_n_cycle >> fs [] >> qexistsl_tac [`ls`, `m`, `ms'''`, `ms'`] >> gs [whileTheory.OLEAST_EQ_SOME] @@ -1215,7 +1162,7 @@ rpt strip_tac >| [ fs [weak_exec_n_def, FUNPOW_OPT_compute], Cases_on `y > 0` >- ( - imp_res_tac weak_exec_n_cycle_alt >> + imp_res_tac weak_exec_n_cycle >> fs [] ) >> fs [] @@ -1335,7 +1282,7 @@ subgoal `abstract_loop_jgmt m l le (^invariant) C1 (^variant)` >- ( subgoal `SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME ms'3')` >- ( (* Invariant is kept *) (* By uniqueness theorem (stating no duplicate states before ms' is reached) *) - irule weak_exec_uniqueness_alt >> + irule weak_exec_uniqueness >> fs [] >> conj_tac >| [ qexists_tac `ms'` >> From 45f25bfe93070c5e2c3db49359ca6b5b0a4c8ba0 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 31 May 2022 10:14:41 +0200 Subject: [PATCH 0114/1015] Some cleanup --- src/aux/bir_auxiliaryScript.sml | 197 +++ .../abstract_hoare_logicScript.sml | 161 +- .../abstract_hoare_logicSimps.sml | 4 +- .../abstract_hoare_logic_auxScript.sml | 1302 ++++++++++++++--- .../abstract_hoare_logic_partialScript.sml | 1016 +------------ 5 files changed, 1284 insertions(+), 1396 deletions(-) diff --git a/src/aux/bir_auxiliaryScript.sml b/src/aux/bir_auxiliaryScript.sml index 52d7c076c..8b710f868 100644 --- a/src/aux/bir_auxiliaryScript.sml +++ b/src/aux/bir_auxiliaryScript.sml @@ -199,6 +199,39 @@ SIMP_TAC arith_ss [rich_listTheory.SEG_TAKE_DROP] >> REPEAT STRIP_TAC >> ASM_SIMP_TAC list_ss [rich_listTheory.DROP_EL_CONS, arithmeticTheory.ADD1]); +Theorem INDEX_FIND_SUFFIX: +!P n i x_list x. +i < n ==> +INDEX_FIND 0 P x_list = SOME (PRE n, x) ==> +INDEX_FIND 0 P (DROP i x_list) = SOME (PRE (n - i), x) +Proof +rpt strip_tac >> +fs [INDEX_FIND_EQ_SOME_0] >> +rpt strip_tac >| [ + subgoal `EL (PRE (n - i)) (DROP i x_list) = EL ((PRE (n - i)) + i) x_list` >- ( + irule listTheory.EL_DROP >> + fs [] + ) >> + fs [] >> + `i + PRE (n - i) = PRE n` suffices_by ( + rpt strip_tac >> + fs [] + ) >> + fs [], + + subgoal `j' + i < PRE n` >- ( + fs [arithmeticTheory.LESS_MONO_ADD_EQ] + ) >> + Q.SUBGOAL_THEN `EL j' (DROP i x_list) = EL (j' + i) x_list` (fn thm => fs [thm]) >- ( + irule listTheory.EL_DROP >> + fs [] + ) >> + QSPECL_X_ASSUM ``!j'. j' < PRE n ==> ~P (EL j' x_list)`` [`i + j'`] >> + fs [] +] +QED + + (* -------------------------------------------------------------------------- *) (* pred_set lemmata *) @@ -371,6 +404,54 @@ BasicProvers.VAR_EQ_TAC >> `~(n1 < n2)` by METIS_TAC[] >> DECIDE_TAC); +Theorem MEM_OLEAST: + !l x. + MEM x l ==> + ?i. (OLEAST i. oEL i l = SOME x) = SOME i +Proof +Induct >> ( + fs [listTheory.MEM, listTheory.LENGTH] +) >> +rpt strip_tac >| [ + qexists_tac `0` >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM], + + qpat_assum `!x. _` (fn thm => imp_res_tac thm) >> + Cases_on `h = x` >- ( + qexists_tac `0` >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] + ) >> + qexists_tac `SUC i` >> + fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> + rpt strip_tac >> + Cases_on `i'` >- ( + fs [] + ) >> + QSPECL_X_ASSUM ``!i'. _`` [`n`] >> + gs [] +] +QED + +Theorem FILTER_HD_OLEAST: + !P l l'. + FILTER P l = l' ==> + LENGTH l' > 0 ==> + ?i. (OLEAST i. oEL i l = SOME (HD l')) = SOME i +Proof +rpt strip_tac >> +subgoal `MEM (HD l') l'` >- ( + Cases_on `l'` >> ( + fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] + ) +) >> +subgoal `MEM (HD l') l` >- ( + metis_tac [listTheory.MEM_FILTER] +) >> +imp_res_tac MEM_OLEAST >> +qexists_tac `i` >> +fs [] +QED + (* -------------------------------------------------------------------------- *) (* Optional Minimum *) @@ -487,6 +568,11 @@ val OPT_CONS_REVERSE = store_thm ("OPT_CONS_REVERSE", Cases >> SIMP_TAC list_ss [OPT_CONS_REWRS]); +(*******************) +(* FUNPOW_OPT *) +(*******************) +(* TODO: How about renaming this to oFUNPOW? Similar to oEL, OLEAST, ... *) + val FUNPOW_OPT_def = Define ` FUNPOW_OPT (r : 'a -> 'a option) n x = FUNPOW (\x. option_CASE x NONE r) n (SOME x)` @@ -575,6 +661,117 @@ Cases_on `FUNPOW_OPT step_fun n' s` >| [ ] ); +Theorem FUNPOW_ASSOC: + !f m n x. + FUNPOW f m (FUNPOW f n x) = FUNPOW f n (FUNPOW f m x) +Proof +fs [GSYM arithmeticTheory.FUNPOW_ADD] +QED + +Theorem FUNPOW_OPT_step: + !f n x x' x''. + FUNPOW_OPT f (SUC n) x = SOME x'' ==> + f x = SOME x' ==> + FUNPOW_OPT f n x' = SOME x'' +Proof +rpt strip_tac >> +fs [FUNPOW_OPT_REWRS] +QED + +Theorem FUNPOW_OPT_PRE: + !f n x x' x''. + n > 0 ==> + FUNPOW_OPT f n x = SOME x' ==> + f x = SOME x'' ==> + FUNPOW_OPT f (PRE n) x'' = SOME x' +Proof +rpt strip_tac >> +Cases_on `n` >> ( + fs [FUNPOW_OPT_REWRS] +) +QED + +(* TODO: Use FUNPOW_OPT_next_n_NONE instead of this *) +Theorem FUNPOW_OPT_ADD_NONE: + !f n n' ms ms'. + FUNPOW_OPT f n ms = SOME ms' ==> + FUNPOW_OPT f n' ms' = NONE ==> + FUNPOW_OPT f (n'+n) ms = NONE +Proof +metis_tac [FUNPOW_OPT_def, + arithmeticTheory.FUNPOW_ADD] +QED + +Theorem FUNPOW_OPT_INTER: + !f n n' ms ms' ms''. + FUNPOW_OPT f n ms = SOME ms' ==> + FUNPOW_OPT f (n'+n) ms = SOME ms'' ==> + FUNPOW_OPT f n' ms' = SOME ms'' +Proof +metis_tac [FUNPOW_OPT_def, + arithmeticTheory.FUNPOW_ADD] +QED + +Theorem FUNPOW_SUB: + !f m n x. + m > n ==> + FUNPOW f (m - n) (FUNPOW f n x) = FUNPOW f m x +Proof +fs [GSYM arithmeticTheory.FUNPOW_ADD] +QED + +Theorem FUNPOW_OPT_split: +!f n' n s s'' s'. +n > n' ==> +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f (n - n') s = SOME s'' ==> +FUNPOW_OPT f n' s'' = SOME s' +Proof +rpt strip_tac >> +irule FUNPOW_OPT_INTER >> +qexistsl_tac [`s`, `n - n'`] >> +fs [] +QED + +Theorem FUNPOW_OPT_split2: +!f n' n s s'' s'. +n > n' ==> +FUNPOW_OPT f n s = SOME s' ==> +FUNPOW_OPT f n' s = SOME s'' ==> +FUNPOW_OPT f (n - n') s'' = SOME s' +Proof +rpt strip_tac >> +metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +QED + +(* TODO: Relax the first OLEAST? *) +Theorem FUNPOW_OPT_cycle: + !f s s' n n'. + (OLEAST n. n > 0 /\ FUNPOW_OPT f n s = SOME s) = SOME n ==> + s <> s' ==> + (OLEAST n'. FUNPOW_OPT f n' s = SOME s') = SOME n' ==> + n' < n +Proof +rpt strip_tac >> +CCONTR_TAC >> +Cases_on `n' = n` >- ( + fs [whileTheory.OLEAST_EQ_SOME] +) >> +subgoal `n' > n` >- ( + gs [] +) >> +subgoal `FUNPOW_OPT f (n' - n) s = SOME s'` >- ( + irule FUNPOW_OPT_split2 >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `s` >> + fs [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT f n'' s <> SOME s'`` [`n' - n`] >> +gs [] +QED + + (* -------------------------------------------------------------------------- *) (* lazy lists *) (* -------------------------------------------------------------------------- *) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml index 537f74d85..59cc37043 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicScript.sml @@ -4,166 +4,11 @@ open bir_auxiliaryLib; open bir_auxiliaryTheory; -val _ = new_theory "abstract_hoare_logic"; - -(* Transition system *) -val _ = Datatype `abstract_model_t = - <|(* Transition function *) - trs : 'a -> 'a option; - (* Weak transition relation *) - weak : 'a -> ('b -> bool) -> 'a -> bool; - (* A function to obtain the control state from a state. - * This allows for isolating parts of the state that - * the weak transition is provably oblivious to. *) - pc : 'a -> 'b - |>`; - -(* An abstract model is a weak model if this property is fulfilled. - * This is how the weak transition is forced to be related to - * the single transition. *) -val weak_model_def = Define ` - weak_model m = - !ms ls ms'. - (m.weak ms ls ms') = - ?n. - ((n > 0) /\ - (FUNPOW_OPT m.trs n ms = SOME ms') /\ - ((m.pc ms') IN ls) - ) /\ - !n'. - (((n' < n) /\ (n' > 0)) ==> - ?ms''. - (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ - (~((m.pc ms'') IN ls)) - )`; - - -val weak_comp_thm = store_thm("weak_comp_thm", -``!m. - weak_model m ==> - !ms ls1 ls2 ms' ms''. - (m.weak ms (ls1 UNION ls2) ms') ==> (~((m.pc ms') IN ls2)) ==> - (m.weak ms' ls2 ms'') ==> (m.weak ms ls2 ms'')``, - -REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -EXISTS_TAC ``n'+n:num`` >> -ASSUME_TAC (Q.SPECL [`m.trs`, `n'`, `n`, `ms`, `ms'`, `ms''`] FUNPOW_OPT_ADD_thm) >> -REV_FULL_SIMP_TAC arith_ss [] >> -REPEAT STRIP_TAC >> -Cases_on `n'' < n'` >- ( - METIS_TAC [pred_setTheory.IN_UNION] -) >> -Cases_on `n'' = n'` >- ( - METIS_TAC [] -) >> -SUBGOAL_THEN ``n'':num = (n''-n')+n'`` ASSUME_TAC >- (FULL_SIMP_TAC arith_ss []) >> -QSPECL_X_ASSUM ``!n''.((n'' < n:num) /\ (n'' > 0)) ==> P`` [`n''-n':num`] >> -REV_FULL_SIMP_TAC arith_ss [] >> -ASSUME_TAC (Q.SPECL [`m.trs`, `n'`, `n''-n'`, `ms`, `ms'`, `ms'''`] FUNPOW_OPT_ADD_thm) >> -REV_FULL_SIMP_TAC arith_ss [] -); - - -val weak_unique_thm = store_thm("weak_unique_thm", -``!m. - (weak_model m) ==> - !ms ls ms' ms''. - (m.weak ms ls ms') ==> - (m.weak ms ls ms'') ==> - (ms' = ms'') -``, - -REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -Q.SUBGOAL_THEN `n = n'` (FULLSIMP_BY_THM arith_ss) >> -Cases_on `n < n'` >- ( - QSPECL_X_ASSUM ``!n'':num.(n'' < n' /\ n'' > 0) ==> P`` [`n:num`] >> - REV_FULL_SIMP_TAC std_ss [] -) >> -Cases_on `n > n'` >- ( - QSPECL_X_ASSUM ``!n'':num.(n'' < n /\ n'' > 0) ==> P`` [`n':num`] >> - REV_FULL_SIMP_TAC arith_ss [] -) >> -FULL_SIMP_TAC arith_ss [] -); - -val weak_union_thm = store_thm("weak_union_thm",`` - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - (m.weak ms (ls1 UNION ls2) ms') ==> - (~ ((m.pc ms') IN ls1)) ==> - (m.weak ms ls2 ms')``, - -REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -Q.EXISTS_TAC `n` >> -METIS_TAC [pred_setTheory.IN_UNION] -); - -val weak_union2_thm = store_thm("weak_union2_thm",`` - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - (m.weak ms (ls1 UNION ls2) ms') ==> - (((m.pc ms') IN ls2)) ==> - (m.weak ms ls2 ms')``, - -REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -Q.EXISTS_TAC `n` >> -METIS_TAC [pred_setTheory.IN_UNION] -); - -val weak_union_singleton_thm = prove(`` - !m. - weak_model m ==> - !ms l1 ls2 ms'. - (m.weak ms ({l1} UNION ls2) ms') ==> - ((m.pc ms') <> l1) ==> - (m.weak ms ls2 ms')``, - -METIS_TAC [weak_union_thm, pred_setTheory.IN_SING] -); - -val weak_singleton_pc_thm = prove(`` - !m. - weak_model m ==> - !ms e ms'. - (m.weak ms {e} ms') ==> ((m.pc ms') = e)``, - -METIS_TAC [weak_model_def, pred_setTheory.IN_SING] -); - - -val weak_pc_in_thm = store_thm("weak_pc_in_thm", - ``!m. - weak_model m ==> - !ms ls ms'. - (m.weak ms ls ms') ==> ((m.pc ms') IN ls)``, - -METIS_TAC [weak_model_def] -); - -val weak_union_pc_not_in_thm = store_thm("weak_union_pc_not_in_thm", - ``!m. - weak_model m ==> - !ms e ls1 ls2 ms'. - (m.weak ms (ls1 UNION ls2) ms') ==> - (~((m.pc ms') IN ls2)) ==> - (m.weak ms ls1 ms')``, - -REPEAT STRIP_TAC >> -REV_FULL_SIMP_TAC std_ss [weak_model_def] >> -METIS_TAC [pred_setTheory.IN_UNION] -); - +open abstract_hoare_logic_auxTheory; +val _ = new_theory "abstract_hoare_logic"; -(* Judgment of the logic *) -(* Pre and post usually have conditions on execution mode and code in memory, - also post is usually a map that depends on the end state address *) +(* Judgment of the total-correctness logic *) val abstract_jgmt_def = Define ` abstract_jgmt m (l:'a) (ls:'a->bool) pre post = !ms . diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logicSimps.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logicSimps.sml index 17750ae90..46cf9aded 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logicSimps.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logicSimps.sml @@ -2,10 +2,10 @@ structure abstract_hoare_logicSimps :> abstract_hoare_logicSimps = struct open HolKernel boolLib liteLib simpLib Parse bossLib; -open abstract_hoare_logicTheory; +open abstract_hoare_logic_auxTheory; val wm_type = mk_thy_type {Tyop="abstract_model_t", - Thy="abstract_hoare_logic", + Thy="abstract_hoare_logic_aux", Args=[``:bir_state_t``, ``:bir_label_t``] }; diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml index 730f28150..163405433 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_auxScript.sml @@ -6,321 +6,1179 @@ open bir_auxiliaryTheory; val _ = new_theory "abstract_hoare_logic_aux"; -(*******************) -(* Generic lemmata *) -(*******************) +(* Transition system *) +val _ = Datatype `abstract_model_t = + <|(* Transition function *) + trs : 'a -> 'a option; + (* Weak transition relation *) + weak : 'a -> ('b -> bool) -> 'a -> bool; + (* A function to obtain the control state from a state. + * This allows for isolating parts of the state that + * the weak transition is provably oblivious to. *) + pc : 'a -> 'b + |>`; -Theorem EL_LAST_APPEND: - !l x. - EL (LENGTH l) (l ++ [x]) = x +(* An abstract model is a weak model if this property is fulfilled. + * This is how the weak relation is related to + * the single transition function. *) +val weak_model_def = Define ` + weak_model m = + !ms ls ms'. + (m.weak ms ls ms') = + ?n. + ((n > 0) /\ + (FUNPOW_OPT m.trs n ms = SOME ms') /\ + ((m.pc ms') IN ls) + ) /\ + !n'. + (((n' < n) /\ (n' > 0)) ==> + ?ms''. + (FUNPOW_OPT m.trs n' ms = SOME ms'') /\ + (~((m.pc ms'') IN ls)) + )`; + + +val weak_comp_thm = store_thm("weak_comp_thm", +``!m. + weak_model m ==> + !ms ls1 ls2 ms' ms''. + (m.weak ms (ls1 UNION ls2) ms') ==> (~((m.pc ms') IN ls2)) ==> + (m.weak ms' ls2 ms'') ==> (m.weak ms ls2 ms'')``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +EXISTS_TAC ``n'+n:num`` >> +ASSUME_TAC (Q.SPECL [`m.trs`, `n'`, `n`, `ms`, `ms'`, `ms''`] FUNPOW_OPT_ADD_thm) >> +REV_FULL_SIMP_TAC arith_ss [] >> +REPEAT STRIP_TAC >> +Cases_on `n'' < n'` >- ( + METIS_TAC [pred_setTheory.IN_UNION] +) >> +Cases_on `n'' = n'` >- ( + METIS_TAC [] +) >> +SUBGOAL_THEN ``n'':num = (n''-n')+n'`` ASSUME_TAC >- (FULL_SIMP_TAC arith_ss []) >> +QSPECL_X_ASSUM ``!n''.((n'' < n:num) /\ (n'' > 0)) ==> P`` [`n''-n':num`] >> +REV_FULL_SIMP_TAC arith_ss [] >> +ASSUME_TAC (Q.SPECL [`m.trs`, `n'`, `n''-n'`, `ms`, `ms'`, `ms'''`] FUNPOW_OPT_ADD_thm) >> +REV_FULL_SIMP_TAC arith_ss [] +); + + +val weak_unique_thm = store_thm("weak_unique_thm", +``!m. + (weak_model m) ==> + !ms ls ms' ms''. + (m.weak ms ls ms') ==> + (m.weak ms ls ms'') ==> + (ms' = ms'') +``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +Q.SUBGOAL_THEN `n = n'` (FULLSIMP_BY_THM arith_ss) >> +Cases_on `n < n'` >- ( + QSPECL_X_ASSUM ``!n'':num.(n'' < n' /\ n'' > 0) ==> P`` [`n:num`] >> + REV_FULL_SIMP_TAC std_ss [] +) >> +Cases_on `n > n'` >- ( + QSPECL_X_ASSUM ``!n'':num.(n'' < n /\ n'' > 0) ==> P`` [`n':num`] >> + REV_FULL_SIMP_TAC arith_ss [] +) >> +FULL_SIMP_TAC arith_ss [] +); + +val weak_union_thm = store_thm("weak_union_thm",`` + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + (m.weak ms (ls1 UNION ls2) ms') ==> + (~ ((m.pc ms') IN ls1)) ==> + (m.weak ms ls2 ms')``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +Q.EXISTS_TAC `n` >> +METIS_TAC [pred_setTheory.IN_UNION] +); + +val weak_union2_thm = store_thm("weak_union2_thm",`` + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + (m.weak ms (ls1 UNION ls2) ms') ==> + (((m.pc ms') IN ls2)) ==> + (m.weak ms ls2 ms')``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +Q.EXISTS_TAC `n` >> +METIS_TAC [pred_setTheory.IN_UNION] +); + +val weak_union_singleton_thm = prove(`` + !m. + weak_model m ==> + !ms l1 ls2 ms'. + (m.weak ms ({l1} UNION ls2) ms') ==> + ((m.pc ms') <> l1) ==> + (m.weak ms ls2 ms')``, + +METIS_TAC [weak_union_thm, pred_setTheory.IN_SING] +); + +val weak_singleton_pc_thm = prove(`` + !m. + weak_model m ==> + !ms e ms'. + (m.weak ms {e} ms') ==> ((m.pc ms') = e)``, + +METIS_TAC [weak_model_def, pred_setTheory.IN_SING] +); + + +val weak_pc_in_thm = store_thm("weak_pc_in_thm", + ``!m. + weak_model m ==> + !ms ls ms'. + (m.weak ms ls ms') ==> ((m.pc ms') IN ls)``, + +METIS_TAC [weak_model_def] +); + +val weak_union_pc_not_in_thm = store_thm("weak_union_pc_not_in_thm", + ``!m. + weak_model m ==> + !ms e ls1 ls2 ms'. + (m.weak ms (ls1 UNION ls2) ms') ==> + (~((m.pc ms') IN ls2)) ==> + (m.weak ms ls1 ms')``, + +REPEAT STRIP_TAC >> +REV_FULL_SIMP_TAC std_ss [weak_model_def] >> +METIS_TAC [pred_setTheory.IN_UNION] +); + +Definition ominus_def: + (ominus NONE _ = NONE) /\ + (ominus _ NONE = NONE) /\ + (ominus (SOME (n:num)) (SOME n') = SOME (n - n')) +End + +Theorem weak_superset_thm: + !m. + weak_model m ==> + !ms ms' ls1 ls2. + m.weak ms ls1 ms' ==> + ?ms''. m.weak ms (ls1 UNION ls2) ms'' Proof rpt strip_tac >> -ASSUME_TAC (ISPEC ``l ++ [x]`` rich_listTheory.EL_PRE_LENGTH) >> -fs [GSYM arithmeticTheory.ADD1] +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +Cases_on `(OLEAST n'. ?ms''. n' > 0 /\ n' < n /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' IN ls2)` >- ( + fs [] >> + qexistsl_tac [`ms'`, `n`] >> + fs [] >> + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_NONE] >> + metis_tac [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +qexistsl_tac [`ms''`, `x`] >> +fs [] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> +gs [] >> +QSPECL_X_ASSUM ``!n'. + n' < x ==> + !ms'4'. + FUNPOW_OPT m.trs n' ms = SOME ms'4' ==> + ~(n' > 0) \/ m.pc ms'4' NOTIN ls2`` [`n''`] >> +gs [] QED -Theorem LAST_TAKE_EL: - !n l. - n < LENGTH l ==> - EL n l = LAST (TAKE (SUC n) l) +Theorem weak_nonempty: + !m. + weak_model m ==> + !ms ls. + m.weak ms ls <> {} <=> (?ms'. m.weak ms ls ms') Proof rpt strip_tac >> -subgoal `(TAKE (SUC n) l) <> []` >- ( - subgoal `LENGTH (TAKE (SUC n) l) = SUC n` >- ( - irule listTheory.LENGTH_TAKE >> - fs [] - ) >> - Cases_on `l` >> ( - fs [] - ) -) >> -IMP_RES_TAC listTheory.LAST_EL >> -fs [] >> -metis_tac [listTheory.EL_TAKE, prim_recTheory.LESS_SUC_REFL] +fs [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> +eq_tac >> (rpt strip_tac) >| [ + qexists_tac `x` >> + fs [pred_setTheory.IN_APP], + + qexists_tac `ms'` >> + fs [pred_setTheory.IN_APP] +] QED -Theorem INDEX_FIND_MEM: - !P l x. - P x ==> - MEM x l ==> - ?i x'. INDEX_FIND 0 P l = SOME (i, x') +Theorem weak_inter: + !m. + weak_model m ==> + !ms ms' ms'' ls1 ls2. + DISJOINT ls1 ls2 ==> + m.weak ms ls2 ms' ==> + m.weak ms (ls1 UNION ls2) ms'' ==> + m.pc ms'' IN ls1 ==> + m.weak ms'' ls2 ms' Proof -Induct_on `l` >> ( +rpt strip_tac >> +(* ms goes to ms' in n steps. ms goes to ms'' in n' steps, for which: + * n'>n: impossible, by the first-encounter property + * n=n': impossible, since ms' is in ls2 and ms'' is in ls1 (disjoint sets) + * n' fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +subgoal `~(n'>n)` >- ( + QSPECL_X_ASSUM ``!n''. + n'' < n' /\ n'' > 0 ==> + ?ms'3'. + FUNPOW_OPT m.trs n'' ms = SOME ms'3' /\ m.pc ms'3' NOTIN ls1 /\ + m.pc ms'3' NOTIN ls2`` [`n`] >> + gs [] +) >> +subgoal `~(n'=n)` >- ( + strip_tac >> + gs [] >> + metis_tac [pred_setTheory.IN_DISJOINT] +) >> +subgoal `n'- ( fs [] ) >> +qexists_tac `n-n'` >> rpt strip_tac >| [ - qexists_tac `0` >> - qexists_tac `h` >> - fs [INDEX_FIND_EQ_SOME_0], - - Cases_on `P h` >| [ - qexists_tac `0` >> - qexists_tac `h` >> - fs [INDEX_FIND_EQ_SOME_0], - - RES_TAC >> - qexists_tac `SUC i` >> - qexists_tac `x'` >> - fs [listTheory.INDEX_FIND_def] >> - REWRITE_TAC [Once listTheory.INDEX_FIND_add] >> - fs [] - ] + fs [], + + (* by combining execution *) + irule FUNPOW_OPT_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [], + + (* non-encounter in earlier steps *) + QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n' + n''`] >> + gs [] >> + qexists_tac `ms'''` >> + fs [] >> + metis_tac [FUNPOW_OPT_INTER, arithmeticTheory.ADD_COMM] ] QED -Theorem MEM_HD: - !l. - l <> [] ==> - MEM (HD l) l +Theorem weak_least_trs: + !m ms ls ms'. + weak_model m ==> + ms <> ms' ==> + m.weak ms ls ms' ==> + ?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' ms = SOME ms') = SOME n' Proof -Cases_on `l` >> ( +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +qexists_tac `n` >> +fs [whileTheory.OLEAST_EQ_SOME] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> +gs [] >> +subgoal `n' = 0` >- ( fs [] -) +) >> +rw [] >> +gs [FUNPOW_OPT_compute] QED -Theorem FILTER_MEM: - !P l l' x. - FILTER P l = l' ==> - MEM x l' ==> - P x /\ MEM x l +Theorem weak_union_pc: + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms''. + m.weak ms ls2 ms' ==> + m.weak ms (ls1 UNION ls2) ms'' ==> + ms' <> ms'' ==> + m.pc ms'' IN ls1 Proof -rw [] >> -fs [listTheory.MEM_FILTER] +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> +Cases_on `n' > n` >- ( + QSPECL_X_ASSUM ``!n''. + n'' < n' /\ n'' > 0 ==> + ?ms'3'. + FUNPOW_OPT m.trs n'' ms = SOME ms'3' /\ m.pc ms'3' NOTIN ls1 /\ + m.pc ms'3' NOTIN ls2`` [`n`] >> + gs [] +) >> +Cases_on `n' = n` >- ( + gs [] +) >> +QSPECL_X_ASSUM ``!n'. + n' < n /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n'`] >> +gs [] QED -(* -Theorem MEM_EL_CONS: - !n e l. - n > 0 ==> - n < SUC (LENGTH l) ==> - MEM (EL n (e::l)) l +Theorem weak_subset: + !m. weak_model m ==> + !ms ls1 ls2 ms'. + m.weak ms (ls1 UNION ls2) ms' ==> + ls1 SUBSET ls2 ==> + m.weak ms ls2 ms' Proof rpt strip_tac >> -fs [listTheory.MEM_EL] >> -qexists_tac `PRE n` >> -fs [] >> -irule rich_listTheory.EL_CONS >> -fs [] +fs [pred_setTheory.SUBSET_UNION_ABSORPTION] QED -*) -(* -Theorem FILTER_NOT_MEM: -!P l l' x. -FILTER P l = l' ==> -MEM x l ==> -~MEM x l' ==> -~P x + +(****************************) +(* Weak transition function *) +(****************************) + +(* This is a non-executable function that computes a state (Hilbert's choice of one) + * that is related to the given initial state by weak to ls. *) +Definition weak_exec_def: + (weak_exec m ls ms = + let + MS' = m.weak ms ls + in + if MS' = {} + then NONE + else SOME (CHOICE MS')) +End + +(* The above, applied multiple times *) +Definition weak_exec_n_def: + (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) +End + +Theorem weak_exec_exists: + !m. + weak_model m ==> + !ms ls ms'. + m.weak ms ls ms' <=> + weak_exec m ls ms = SOME ms' Proof rpt strip_tac >> -rw [] >> -fs [listTheory.MEM_FILTER] +fs [weak_exec_def] >> +eq_tac >> ( + strip_tac +) >| [ + subgoal `m.weak ms ls = {ms'}` >- ( + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> + metis_tac [weak_unique_thm] + ) >> + fs [], + + metis_tac [pred_setTheory.CHOICE_DEF, pred_setTheory.IN_APP] +] +QED + +(* TODO: Replace weak with weak_exec_n of 1 in the below? *) + +Theorem weak_exec_to_n: + !m. + weak_model m ==> + !ms ls ms'. + weak_exec m ls ms = SOME ms' <=> + weak_exec_n m ms ls 1 = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_n_def, FUNPOW_OPT_def] +QED + +Theorem weak_exec_n_prev: + !m. + weak_model m ==> + !ms ls ms' n_l. + weak_exec_n m ms ls (SUC n_l) = SOME ms' ==> + ?ms''. weak_exec_n m ms ls n_l = SOME ms'' /\ weak_exec_n m ms'' ls 1 = SOME ms' +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +subgoal `SUC n_l > 0` >- ( + fs [] +) >> +imp_res_tac FUNPOW_OPT_prev_EXISTS >> +QSPECL_X_ASSUM ``!n'. _`` [`n_l`] >> +fs [] >> +Cases_on `n_l = 0` >- ( + gs [FUNPOW_OPT_compute] +) >> +irule FUNPOW_OPT_split >> +qexistsl_tac [`SUC n_l`, `ms`] >> +fs [arithmeticTheory.ADD1] +QED + +(* TODO: Useful? +Theorem weak_exec_n_split: +!m. weak_model m ==> +!s s' s'' ls n n'. +n > n' ==> +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s ls (n - n') = SOME s'' ==> +weak_exec_n m s'' ls n' = SOME s' +Proof +cheat QED *) -Theorem MEM_OLEAST: -!l x. -MEM x l ==> -?i. (OLEAST i. oEL i l = SOME x) = SOME i +Theorem weak_exec_n_split2: +!m. weak_model m ==> +!s s' s'' ls n n'. +n >= n' ==> +weak_exec_n m s ls n' = SOME s'' ==> +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s'' ls (n - n') = SOME s' Proof -Induct >> ( - fs [listTheory.MEM, listTheory.LENGTH] +rpt strip_tac >> +fs [weak_exec_n_def] >> +Cases_on `n = n'` >- ( + fs [FUNPOW_OPT_compute] ) >> -rpt strip_tac >| [ - qexists_tac `0` >> - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM], +subgoal `n > n'` >- ( + fs [] +) >> +metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +QED - qpat_assum `!x. _` (fn thm => imp_res_tac thm) >> - Cases_on `h = x` >- ( - qexists_tac `0` >> - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] - ) >> - qexists_tac `SUC i` >> - fs [whileTheory.OLEAST_EQ_SOME, listTheory.oEL_THM] >> - rpt strip_tac >> - Cases_on `i'` >- ( - fs [] - ) >> - QSPECL_X_ASSUM ``!i'. _`` [`n`] >> + +Theorem weak_exec_n_cycle: + !m s s' ls n_l n_l'. + weak_model m ==> + n_l > 0 /\ weak_exec_n m s ls n_l = SOME s ==> + s <> s' ==> + (OLEAST n_l'. weak_exec_n m s ls n_l' = SOME s') = SOME n_l' ==> + n_l' < n_l +Proof +rpt strip_tac >> +CCONTR_TAC >> +Cases_on `n_l' = n_l` >- ( + fs [whileTheory.OLEAST_EQ_SOME] +) >> +subgoal `n_l' > n_l` >- ( gs [] -] +) >> +subgoal `weak_exec_n m s ls (n_l' - n_l) = SOME s'` >- ( + irule weak_exec_n_split2 >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `s` >> + fs [] +) >> +fs [whileTheory.OLEAST_EQ_SOME] >> +QSPECL_X_ASSUM ``!n_l''. n_l'' < n_l' ==> weak_exec_n m s ls n_l'' <> SOME s'`` [`n_l' - n_l`] >> +gs [] +QED + +(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' + * Let this rely on sub-lemma for incrementing weak_exec_n instead + * of reasoning on FUNPOW_OPT *) +Theorem weak_exec_incr_last: + !m. + weak_model m ==> + !ms ls ms' n_l ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + m.weak ms' ls ms'' ==> + weak_exec_n m ms ls (SUC n_l) = SOME ms'' +Proof +rpt strip_tac >> +simp [weak_exec_n_def, arithmeticTheory.ADD1] >> +ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> +irule FUNPOW_OPT_ADD_thm >> +qexists_tac `ms'` >> +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> +simp [FUNPOW_OPT_def] >> +metis_tac [weak_exec_exists] +QED + +Theorem weak_exec_incr_first: + !m. + weak_model m ==> + !ms ls ms' n_l ms''. + m.weak ms ls ms' ==> + (OLEAST n. weak_exec_n m ms' ls n = SOME ms'') = SOME n_l ==> + weak_exec_n m ms ls (SUC n_l) = SOME ms'' +Proof +rpt strip_tac >> +simp [weak_exec_n_def, arithmeticTheory.ADD1] >> +irule FUNPOW_OPT_ADD_thm >> +qexists_tac `ms'` >> +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> +simp [FUNPOW_OPT_def] >> +metis_tac [weak_exec_exists] QED +Theorem weak_exec_n_add: +!m. weak_model m ==> +!s s' s'' ls n n'. +weak_exec_n m s ls n = SOME s' ==> +weak_exec_n m s' ls n' = SOME s'' ==> +weak_exec_n m s ls (n + n') = SOME s'' +Proof +rpt strip_tac >> +fs [weak_exec_n_def] >> +metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] +QED -Theorem FILTER_HD_OLEAST_EXISTS: - !P l l'. - FILTER P l = l' ==> - LENGTH l' > 0 ==> - ?i. (OLEAST i. oEL i l = SOME (HD l')) = SOME i +Theorem weak_exec_n_inter: + !m. + weak_model m ==> + !ms ms' ls1 ls2 n_l n_l'. + DISJOINT ls1 ls2 ==> + weak_exec_n m ms ls2 1 = SOME ms' ==> + (OLEAST n_l. weak_exec_n m ms (ls1 UNION ls2) n_l = SOME ms') = SOME n_l ==> + n_l' < n_l ==> + !ms''. + (OLEAST n_l. weak_exec_n m ms (ls1 UNION ls2) n_l = SOME ms'') = SOME n_l' ==> + weak_exec_n m ms'' ls2 1 = SOME ms' Proof +ntac 7 strip_tac >> +Induct_on `n_l'` >- ( + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def, FUNPOW_OPT_compute] +) >> rpt strip_tac >> -subgoal `MEM (HD l') l'` >- ( - irule MEM_HD >> - fs [listTheory.NOT_NIL_EQ_LENGTH_NOT_0] +gs [whileTheory.OLEAST_EQ_SOME] >> +imp_res_tac weak_exec_n_prev >> +QSPECL_X_ASSUM ``!ms'3'. + weak_exec_n m ms (ls1 UNION ls2) n_l' = SOME ms'3' /\ + (!n_l. + n_l < n_l' ==> + weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms'3') ==> + weak_exec_n m ms'3' ls2 1 = SOME ms'`` [`ms'''`] >> +gs [] >> +subgoal `!n_l. n_l < n_l' ==> weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms'3'` >- ( + rpt strip_tac >> + QSPECL_X_ASSUM ``!n_l. + n_l < SUC n_l' ==> + weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms''`` [`SUC n_l''`] >> + gs [] >> + metis_tac [weak_exec_n_add, arithmeticTheory.ADD1] ) >> -subgoal `MEM (HD l') l` >- ( - metis_tac [listTheory.MEM_FILTER] +fs [] >> +(* TODO: Build together that you can proceed one weak transition to superset from ms''', + * and from the reach ms' whith next weak transition to ls2 *) +(* See reasoning in weak_inter *) +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> +irule weak_inter >> +fs [] >> +qexistsl_tac [`ls1`, `ms'''`] >> +fs [] >> +subgoal `ms' <> ms''` >- ( +QSPECL_X_ASSUM ``!n_l'. + n_l' < n_l ==> weak_exec_n m ms (ls1 UNION ls2) n_l' <> SOME ms'`` [`SUC n_l'`] >> + gs [] +) >> +metis_tac [weak_union_pc] +QED + +Theorem weak_inter_exec: + !m. + weak_model m ==> + !ms ls1 ls2 n_l ms' ms''. + m.weak ms ls2 ms' ==> + DISJOINT ls1 ls2 ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> + SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') ==> + m.weak ms'' ls2 ms' +Proof +rpt strip_tac >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) >> +irule weak_exec_n_inter >> +fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +qexistsl_tac [`ls1`, `ms`, `n_l`, `x`] >> +fs [] >> +rpt strip_tac >> +QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms (ls1 UNION ls2) y = SOME ms'' ==> x = y`` [`n_l'`] >> +subgoal `n_l' < n_l` >- ( + gs [] ) >> -imp_res_tac MEM_OLEAST >> -qexists_tac `i` >> fs [] QED -Theorem INDEX_FIND_SUFFIX: -!P n i x_list x. -i < n ==> -INDEX_FIND 0 P x_list = SOME (PRE n, x) ==> -INDEX_FIND 0 P (DROP i x_list) = SOME (PRE (n - i), x) +Theorem weak_exec_n_OLEAST_equiv: + !m. weak_model m ==> + !s ls s'. + (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s') = SOME 1 ==> + m.weak s ls s' Proof rpt strip_tac >> -fs [INDEX_FIND_EQ_SOME_0] >> -rpt strip_tac >| [ - subgoal `EL (PRE (n - i)) (DROP i x_list) = EL ((PRE (n - i)) + i) x_list` >- ( - irule listTheory.EL_DROP >> +fs [whileTheory.OLEAST_EQ_SOME] >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) +QED + +(* Continuing weak_exec_n at s'', intermediately between s and s'' *) +Theorem weak_exec_n_OLEAST_inter: + !m. weak_model m ==> + !s s' s'' ls n' n'' n_l. + (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s') = SOME n' ==> + (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' s = SOME s'') = SOME n'' ==> + n' > n'' ==> + (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s'') = SOME 1 ==> + (OLEAST n_l. weak_exec_n m s'' ls n_l = SOME s') = SOME n_l ==> + (OLEAST n_l. weak_exec_n m s ls n_l = SOME s') = SOME (n_l + 1) +Proof +rpt strip_tac >> +simp [whileTheory.OLEAST_EQ_SOME] >> +conj_tac >| [ + metis_tac [arithmeticTheory.ADD1, weak_exec_incr_first, weak_exec_n_OLEAST_equiv], + + fs [whileTheory.OLEAST_EQ_SOME] >> + subgoal `s <> s'` >- ( + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`0`] >> + subgoal `0 < n'` >- ( + fs [] + ) >> + gs [FUNPOW_OPT_compute] + ) >> + subgoal `s'' <> s'` >- ( + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''`] >> + gs [] + ) >> + subgoal `n_l > 0` >- ( + Cases_on `n_l = 0` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ) >> fs [] ) >> + `weak_exec_n m s ls 1 <> SOME s' /\ !n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'` suffices_by ( + rpt strip_tac >> + fs [] >> + QSPECL_X_ASSUM ``!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'`` [`n_l' - 1`] >> + gs [] >> + subgoal `n_l' >= 1` >- ( + Cases_on `n_l' = 0` >- ( + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ) >> + fs [] + ) >> + metis_tac [weak_exec_n_split2] + ) >> + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''`] >> + gs [] +] +QED + +Theorem weak_exec_1_superset_lemma: + !m. + weak_model m ==> + !ls1 ls2 s'. + !n n'. n' <= n ==> + n' >= 1 ==> + !s. m.weak s ls1 s' /\ ((OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s') = SOME n') ==> + s <> s' ==> + ls1 SUBSET ls2 ==> + ?n_l. n_l >= 1 /\ (OLEAST n_l. weak_exec_n m s ls2 n_l = SOME s') = SOME n_l +Proof +ntac 5 strip_tac >> +Induct_on `n` >- ( + fs [] +) >> +rpt strip_tac >> +Cases_on `n' < SUC n` >- ( + QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> + gs [] +) >> +subgoal `n' = SUC n` >- ( + fs [] +) >> +Cases_on `n = 0` >- ( + gs [] >> + subgoal `n' = 1` >- ( + fs [] + ) >> + fs [whileTheory.OLEAST_EQ_SOME] >> + qexists_tac `1` >> fs [] >> - `i + PRE (n - i) = PRE n` suffices_by ( + conj_tac >| [ + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + qexists_tac `1` >> + fs [] >> + metis_tac [weak_pc_in_thm, pred_setTheory.SUBSET_THM], + rpt strip_tac >> + subgoal `n_l' = 0` >- ( + fs [] + ) >> + fs [weak_exec_n_def, FUNPOW_OPT_compute] + ] +) >> +(* 1. There exists a state s'' which we go to with weak-ls2 from s. (weak_superset_thm should suffice) + * s'' is reached with more trs than s': contradiction. + * s'' is reached with same amount of trs as s': s'' is s', proof completed + * with witness n_l''. + * s'' is reached with fewer trs than s': use induction hypothesis specialised for s'', then add + * numbers of weak-ls2 transitions together for the witness. *) +subgoal `?s''. (OLEAST n_l''. n_l'' > 0 /\ weak_exec_n m s ls2 n_l'' = SOME s'') = SOME 1` >- ( + subgoal `?ms''. m.weak s (ls1 UNION ls2) ms''` >- ( + metis_tac [weak_superset_thm] + ) >> + qexistsl_tac [`ms''`] >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [weak_subset, weak_exec_to_n, weak_exec_exists] +) >> +subgoal `?n''. (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' s = SOME s'') = SOME n''` >- ( + (* Since s'' is reached by non-zero weak transitions, there must be a (least) non-zero number of trs + * that reaches it *) + fs [whileTheory.OLEAST_EQ_SOME] >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + qexists_tac `n'''` >> + fs [] >> + rpt strip_tac >> + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n''''`] >> + gs [] +) >> +(* s'' is reached with more trs than s': contradiction, s' would have been crossed *) +Cases_on `n'' > n'` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + subgoal `m.weak s ls2 s''` >- ( + metis_tac [weak_exec_to_n, weak_exec_exists] + ) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + (* TODO: Make some kind of lemma here? *) + Q.SUBGOAL_THEN `n'4' = n''` (fn thm => fs [thm]) >- ( + Cases_on `n'' < n'4'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'4' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n''`] >> + gs [] + ) >> + Cases_on `n'' > n'4'` >- ( + QSPECL_X_ASSUM ``!n'3'. + n'3' < n'' ==> FUNPOW_OPT m.trs n'3' s = SOME s'' ==> ~(n'3' > 0)`` [`n''''`] >> + gs [] + ) >> fs [] ) >> - fs [], - - subgoal `j' + i < PRE n` >- ( - fs [arithmeticTheory.LESS_MONO_ADD_EQ] + (* TODO: Make some kind of lemma here? *) + Q.SUBGOAL_THEN `n'3' = n'` (fn thm => fs [thm]) >- ( + Cases_on `n' < n'3'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> + gs [] + ) >> + Cases_on `n' > n'3'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'''`] >> + gs [] + ) >> + fs [] ) >> - Q.SUBGOAL_THEN `EL j' (DROP i x_list) = EL (j' + i) x_list` (fn thm => fs [thm]) >- ( - irule listTheory.EL_DROP >> + QSPECL_X_ASSUM ``!n'. + n' < n'' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n'`] >> + gs [] >> + metis_tac [pred_setTheory.SUBSET_THM] +) >> +Cases_on `n'' = n'` >- ( + qexists_tac `1` >> + subgoal `s'' = s'` >- ( + fs [whileTheory.OLEAST_EQ_SOME] + ) >> + fs [whileTheory.OLEAST_EQ_SOME] >> + rpt strip_tac >> + subgoal `n_l = 0` >- ( fs [] ) >> - QSPECL_X_ASSUM ``!j'. j' < PRE n ==> ~P (EL j' x_list)`` [`i + j'`] >> + fs [weak_exec_n_def, FUNPOW_OPT_compute] +) >> +subgoal `n'' < n'` >- ( fs [] -] -QED - -Theorem EL_PRE_CONS_EQ: -!i x x_list x_list'. - EL (SUC i) (x::x_list) = EL (SUC i) (x::x_list') ==> - EL i x_list = EL i x_list' -Proof -fs [] -QED - +) >> +QSPECL_X_ASSUM ``!n'. _`` [`n' - n''`] >> +rfs [] >> +subgoal `n' <= n + n''` >- ( + gs [whileTheory.OLEAST_EQ_SOME] +) >> +fs [] >> +QSPECL_X_ASSUM ``!s'''. _`` [`s''`] >> +(* Should be possible to prove with some inter theorem... *) +subgoal `m.weak s'' ls1 s'` >- ( + (* Next state in s'' is s'... *) + PAT_ASSUM ``weak_model m`` (fn thm => simp [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + qexists_tac `n' - n''` >> + fs [] >> + rpt conj_tac >| [ + irule FUNPOW_OPT_split >> + qexistsl_tac [`n'`, `s`] >> + fs [whileTheory.OLEAST_EQ_SOME], -(*******************) -(* FUNPOW_OPT *) -(*******************) + metis_tac [weak_pc_in_thm], -(* -val FUNPOW_ASSOC = prove(`` -!f m n x. -FUNPOW f m (FUNPOW f n x) = FUNPOW f n (FUNPOW f m x)``, + rpt strip_tac >> + fs [whileTheory.OLEAST_EQ_SOME] >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + (* TODO: Make some kind of lemma here? *) + subgoal `n'''' = n'` >- ( + Cases_on `n' < n'4'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'4' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> + gs [] + ) >> + Cases_on `n' > n'4'` >- ( + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''''`] >> + gs [] + ) >> + fs [] + ) >> + gs [] >> + QSPECL_X_ASSUM ``!n'5'. + n'5' < n' /\ n'5' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n'5' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''' + n''`] >> + gs [] >> + qexists_tac `ms''` >> + fs [] >> + irule FUNPOW_OPT_split >> + qexistsl_tac [`n'' + n'3'`, `s`] >> + fs [] + ] +) >> +fs [] >> +subgoal `(OLEAST n'. FUNPOW_OPT m.trs n' s'' = SOME s') = SOME (n' - n'')` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + conj_tac >| [ + irule FUNPOW_OPT_split >> + qexistsl_tac [`n'`, `s`] >> + fs [], -fs [GSYM arithmeticTheory.FUNPOW_ADD] -); -*) + rpt strip_tac >> + QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n'' + n'''`] >> + gs [] >> + metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] + ] +) >> +fs [] >> +subgoal `s'' <> s'` >- ( + (* Since s'' NOTIN ls1, while s' IN ls1 *) + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> + (* TODO: Make some kind of lemma here? *) + Q.SUBGOAL_THEN `n'3' = n'` (fn thm => fs [thm]) >- ( + Cases_on `n' < n'3'` >- ( + QSPECL_X_ASSUM ``!n'. + n' < n'3' /\ n' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + Cases_on `n' > n'3'` >- ( + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + fs [] + ) >> + QSPECL_X_ASSUM ``!n'5'. + n'5' < n' /\ n'5' > 0 ==> + ?ms''. FUNPOW_OPT m.trs n'5' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> + gs [whileTheory.OLEAST_EQ_SOME] >> + strip_tac >> + fs [] +) >> +fs [] >> +qexists_tac `1 + n_l` >> +fs [] >> +irule weak_exec_n_OLEAST_inter >> +fs [] >> +qexistsl_tac [`n''`, `s''`] >> +fs [] +QED -Theorem FUNPOW_OPT_step: - !f n x x' x''. - FUNPOW_OPT f (SUC n) x = SOME x'' ==> - f x = SOME x' ==> - FUNPOW_OPT f n x' = SOME x'' +(* TODO: Generalise this *) +(* TODO: Change weak_exec_n 1 to weak? *) +Theorem weak_exec_1_superset: + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + weak_exec_n m ms ls1 1 = SOME ms' ==> + ms <> ms' ==> + ls1 SUBSET ls2 ==> + ?n. n >= 1 /\ (OLEAST n. weak_exec_n m ms ls2 n = SOME ms') = SOME n Proof rpt strip_tac >> -fs [FUNPOW_OPT_REWRS] -QED +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> +PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> +subgoal `?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' ms = SOME ms') = SOME n'` >- ( + (* Since weak goes from ms to ms', there must be a least number of primitive transitions such that + * ms goes to ms' *) + metis_tac [weak_least_trs] +) >> +irule weak_exec_1_superset_lemma >> +fs [] >> +rpt strip_tac >| [ + qexists_tac `n'` >> + fs [], -Theorem FUNPOW_OPT_INTER: - !f n n' ms ms' ms''. - (FUNPOW_OPT f n ms = SOME ms') ==> - (FUNPOW_OPT f (n'+n) ms = SOME ms'') ==> - (FUNPOW_OPT f n' ms' = SOME ms'') -Proof -metis_tac [FUNPOW_OPT_def, - arithmeticTheory.FUNPOW_ADD] + metis_tac [] +] QED -Theorem FUNPOW_OPT_split: -!f n' n s s'' s'. -n > n' ==> -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f (n - n') s = SOME s'' ==> -FUNPOW_OPT f n' s'' = SOME s' +(* TODO: Strengthen conclusion to state either ms'' is ms', or pc is in ls2? *) +Theorem weak_exec_exists_superset: + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + m.weak ms ls1 ms' ==> + ?ms''. weak_exec m (ls1 UNION ls2) ms = SOME ms'' Proof rpt strip_tac >> -irule FUNPOW_OPT_INTER >> -qexistsl_tac [`s`, `n - n'`] >> -fs [] +fs [weak_exec_def, weak_nonempty] >> +metis_tac [weak_superset_thm] QED -(* TODO: Use FUNPOW_OPT_next_n_NONE instead of this *) -Theorem FUNPOW_OPT_ADD_NONE: - !f n n' ms ms'. - (FUNPOW_OPT f n ms = SOME ms') ==> - (FUNPOW_OPT f n' ms' = NONE) ==> - (FUNPOW_OPT f (n'+n) ms = NONE) +(* Note: ms <> ms' used to avoid proving case where least n is zero *) +Theorem weak_exec_n_exists_superset: + !m. + weak_model m ==> + !ms ls1 ls2 ms'. + m.weak ms ls1 ms' ==> + ms <> ms' ==> + ?n. (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n Proof -metis_tac [FUNPOW_OPT_def, - arithmeticTheory.FUNPOW_ADD] +rpt strip_tac >> +fs [whileTheory.OLEAST_EQ_SOME] >> +subgoal `weak_exec_n m ms ls1 1 = SOME ms'` >- ( + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> + PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) +) >> +imp_res_tac weak_exec_1_superset >> +QSPECL_X_ASSUM ``!ls2. _`` [`ls1 UNION ls2`] >> +fs [] >> +qexists_tac `n` >> +fs [whileTheory.OLEAST_EQ_SOME] QED -Theorem FUNPOW_OPT_PRE: - !f n x x' x''. - n > 0 ==> - FUNPOW_OPT f n x = SOME x' ==> - f x = SOME x'' ==> - FUNPOW_OPT f (PRE n) x'' = SOME x' +Theorem weak_exec_least_nonzero: + !m. + weak_model m ==> + !ms ls ms' n_l. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + ms <> ms' ==> + n_l > 0 Proof rpt strip_tac >> -Cases_on `n` >> ( - fs [FUNPOW_OPT_REWRS] -) +Cases_on `n_l` >> ( + fs [] +) >> +fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def, FUNPOW_OPT_def] QED -Theorem FUNPOW_SUB: - !f m n x. - m > n ==> - FUNPOW f (m - n) (FUNPOW f n x) = FUNPOW f m x +Theorem weak_exec_sing_least_less: + !m. + weak_model m ==> + !ms ls ms' n_l. + SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms') ==> + ?n_l'. (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' /\ n_l' < n_l Proof -fs [GSYM arithmeticTheory.FUNPOW_ADD] +rpt strip_tac >> +fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> +qexists_tac `x` >> +rpt strip_tac >> ( + fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] +) >> +QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms' ==> x = y`` [`n`] >> +gs [] QED -Theorem FUNPOW_OPT_split2: -!f n' n s s'' s'. -n > n' ==> -FUNPOW_OPT f n s = SOME s' ==> -FUNPOW_OPT f n' s = SOME s'' ==> -FUNPOW_OPT f (n - n') s'' = SOME s' + +(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) +Theorem weak_exec_incr_least: + !m. + weak_model m ==> + !ms ls ms' ms_e n_l n_l' ms''. + (OLEAST n. weak_exec_n m ms ls n = SOME ms_e) = SOME n_l ==> + ms'' <> ms_e ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' ==> + m.weak ms' ls ms'' ==> + SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms'') ==> + n_l' < n_l ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME (SUC n_l') Proof rpt strip_tac >> -metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] +imp_res_tac weak_exec_incr_last >> +fs [whileTheory.OLEAST_EQ_SOME] >> +rpt strip_tac >> +subgoal `SUC n_l' < n_l` >- ( + Cases_on `SUC n_l' = n_l` >- ( + fs [] + ) >> + fs [] +) >> +fs [pred_setTheory.SING_DEF] >> +fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +QSPECL_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms'' ==> x = y`` [`SUC n_l'`] >> +QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms'' ==> x = y`` [`n`] >> +gs [] +(* Due to SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms''), + * both weak_exec_n m ms ls (SUC n_l') and weak_exec_n m ms ls n + * can't lead to ms''. NOTE: Requires SUC n_l' < n_l *) +(* OK: If ms' was first encountered at n_l' weak iterations to ls, and + * if one additional weak transition to ls goes to ms'', then if + * ms'' is uniquely encountered before n_l weak transitions to ls and n_l + * is greater than n_l', then SUC n_l' must be the least number of weak transitions + * needed to reach ms'' *) QED -(* TODO: Relax the first OLEAST? *) -Theorem FUNPOW_OPT_cycle: - !f s s' n n'. - (OLEAST n. n > 0 /\ FUNPOW_OPT f n s = SOME s) = SOME n ==> - s <> s' ==> - (OLEAST n'. FUNPOW_OPT f n' s = SOME s') = SOME n' ==> - n' < n +Theorem weak_exec_uniqueness: + !m. + weak_model m ==> + !ms ls ms' ms'' ms''' n_l n_l'. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME n_l' ==> + n_l' < n_l ==> + m.weak ms'' ls ms''' ==> + ms''' <> ms' ==> + SING (\n_l''. n_l'' < n_l /\ weak_exec_n m ms ls n_l'' = SOME ms''') Proof rpt strip_tac >> -CCONTR_TAC >> -Cases_on `n' = n` >- ( - fs [whileTheory.OLEAST_EQ_SOME] +subgoal `weak_exec_n m ms ls (n_l' + 1) = SOME ms'3'` >- ( + irule weak_exec_n_add >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [weak_exec_exists, weak_exec_to_n] ) >> -subgoal `n' > n` >- ( +(* Suppose there exists some earlier encounter of ms''' *) +Cases_on `?n_l''. n_l'' < (n_l' + 1) /\ weak_exec_n m ms ls n_l'' = SOME ms'''` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + subgoal `weak_exec_n m ms''' ls (n_l - (n_l' + 1)) = SOME ms'` >- ( + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [] + ) >> + subgoal `weak_exec_n m ms ls (n_l'' + (n_l - (n_l' + 1))) = SOME ms'` >- ( + irule weak_exec_n_add >> + fs [] >> + qexists_tac `ms'3'` >> + fs [] + ) >> + QSPECL_ASSUM ``!n. n < n_l ==> weak_exec_n m ms ls n <> SOME ms'`` [`(n_l'' + (n_l - (n_l' + 1)))`] >> gs [] ) >> -subgoal `FUNPOW_OPT f (n' - n) s = SOME s'` >- ( - irule FUNPOW_OPT_split2 >> +fs [] >> +(* If there were no earlier encounter of ms''', then the first encounter was at n_l' + 1 *) +subgoal `(OLEAST n_l. weak_exec_n m ms ls n_l = SOME ms''') = SOME (n_l' + 1)` >- ( fs [whileTheory.OLEAST_EQ_SOME] >> - qexists_tac `s` >> + metis_tac [] +) >> + +(* Suppose there exists some later encounter of ms''' *) +Cases_on `?n_l''. n_l'' > (n_l' + 1) /\ n_l'' < n_l /\ weak_exec_n m ms ls n_l'' = SOME ms'''` >- ( + fs [] >> + subgoal `(OLEAST n_l. weak_exec_n m ms''' ls n_l = SOME ms') = SOME (n_l - (n_l' + 1))` >- ( + fs [whileTheory.OLEAST_EQ_SOME] >> + rpt strip_tac >| [ + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [], + + (* TODO: Prove the OLEAST part... *) + subgoal `weak_exec_n m ms ls ((n_l' + 1) + n_l'3') <> SOME ms'` >- ( + QSPECL_ASSUM ``!n. n < n_l ==> weak_exec_n m ms ls n <> SOME ms'`` [`(n_l' + 1) + n_l'3'`] >> + gs [] + ) >> + subgoal `weak_exec_n m ms ls ((n_l' + 1) + n_l'3') = SOME ms'` >- ( + irule weak_exec_n_add >> + fs [] + ) + ] + ) >> + subgoal `weak_exec_n m ms''' ls (n_l'' - (n_l' + 1)) = SOME ms'''` >- ( + irule weak_exec_n_split2 >> + fs [] >> + qexists_tac `ms` >> + fs [] + ) >> + (* By weak_exec_n_cycle *) + subgoal `(n_l - (n_l' + 1)) < (n_l'' - (n_l' + 1))` >- ( + irule weak_exec_n_cycle >> + fs [] >> + qexistsl_tac [`ls`, `m`, `ms'''`, `ms'`] >> + gs [whileTheory.OLEAST_EQ_SOME] + ) >> + gs [] +) >> +fs [] >> +gs [pred_setTheory.SING_DEF, GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +qexists_tac `n_l' + 1` >> +rpt strip_tac >| [ + Cases_on `n_l' + 1 = n_l` >- ( + gvs [whileTheory.OLEAST_EQ_SOME] + ) >> + gs [], + + irule weak_exec_n_add >> + fs [] >> + qexists_tac `ms''` >> + fs [whileTheory.OLEAST_EQ_SOME] >> + metis_tac [weak_exec_exists, weak_exec_to_n], + + res_tac >> + gs [arithmeticTheory.EQ_LESS_EQ, arithmeticTheory.NOT_LESS] +] +QED + +Theorem weak_exec_unique_start: + !m. + weak_model m ==> + !ms ls ms' n_l. + (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> + ms <> ms' ==> + SING (\n_l'. n_l' < n_l /\ weak_exec_n m ms ls n_l' = SOME ms) +Proof +rpt strip_tac >> +gs [pred_setTheory.SING_DEF, GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> +qexists_tac `0` >> +rpt strip_tac >| [ + Cases_on `n_l = 0` >> ( + fs [weak_exec_n_def, FUNPOW_OPT_compute, whileTheory.OLEAST_EQ_SOME] + ), + + fs [weak_exec_n_def, FUNPOW_OPT_compute], + + Cases_on `y > 0` >- ( + imp_res_tac weak_exec_n_cycle >> + fs [] + ) >> + fs [] +] +QED + +(* Uses the fact that exit labels are disjoint from loop point to know that + * we have not yet exited the loop after another weak transition, i.e. the + * number of loops is still less than n_l *) +Theorem weak_exec_less_incr_superset: + !m. + weak_model m ==> + !ms ls1 ls2 ms' ms'' ms''' n_l n_l'. + DISJOINT ls1 ls2 ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> + m.pc ms' IN ls2 ==> + (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') = SOME n_l' ==> + n_l' < n_l ==> + m.weak ms'' (ls1 UNION ls2) ms''' ==> + m.pc ms''' NOTIN ls2 ==> + SUC n_l' < n_l +Proof +rpt strip_tac >> +Cases_on `SUC n_l' = n_l` >- ( + subgoal `ms''' = ms'` >- ( + subgoal `weak_exec_n m ms (ls1 UNION ls2) (SUC n_l') = SOME ms'''` >- ( + metis_tac [weak_exec_incr_last] + ) >> + gs [whileTheory.OLEAST_EQ_SOME] + ) >> fs [] ) >> -fs [whileTheory.OLEAST_EQ_SOME] >> -QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT f n'' s <> SOME s'`` [`n' - n`] >> -gs [] +fs [] QED diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 6e6abfd09..1c9805230 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -8,26 +8,6 @@ open abstract_hoare_logic_auxTheory abstract_hoare_logicTheory; val _ = new_theory "abstract_hoare_logic_partial"; -Definition ominus_def: - (ominus NONE _ = NONE) /\ - (ominus _ NONE = NONE) /\ - (ominus (SOME (n:num)) (SOME n') = SOME (n - n')) -End - -Definition weak_exec_def: - (weak_exec m ls ms = - let - MS' = m.weak ms ls - in - if MS' = {} - then NONE - else SOME (CHOICE MS')) -End - -Definition weak_exec_n_def: - (weak_exec_n m ms ls n = FUNPOW_OPT (weak_exec m ls) n ms) -End - Definition abstract_partial_jgmt_def: abstract_partial_jgmt m (l:'a) (ls:'a->bool) pre post = !ms ms'. @@ -64,8 +44,8 @@ Theorem weak_partial_weakening_rule_thm: !m. !l ls pre1 pre2 post1 post2. weak_model m ==> - (!ms. ((m.pc ms) = l) ==> (pre2 ms) ==> (pre1 ms)) ==> - (!ms. ((m.pc ms) IN ls) ==> (post1 ms) ==> (post2 ms)) ==> + (!ms. ((m.pc ms) = l) ==> pre2 ms ==> pre1 ms) ==> + (!ms. ((m.pc ms) IN ls) ==> post1 ms ==> post2 ms) ==> abstract_partial_jgmt m l ls pre1 post1 ==> abstract_partial_jgmt m l ls pre2 post2 Proof @@ -127,142 +107,6 @@ Proof fs [abstract_jgmt_imp_partial_triple] QED -Theorem weak_superset_thm: - !m. - weak_model m ==> - !ms ms' ls1 ls2. - m.weak ms ls1 ms' ==> - ?ms''. m.weak ms (ls1 UNION ls2) ms'' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -Cases_on `(OLEAST n'. ?ms''. n' > 0 /\ n' < n /\ FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' IN ls2)` >- ( - fs [] >> - qexistsl_tac [`ms'`, `n`] >> - fs [] >> - rpt strip_tac >> - fs [whileTheory.OLEAST_EQ_NONE] >> - metis_tac [] -) >> -fs [whileTheory.OLEAST_EQ_SOME] >> -qexistsl_tac [`ms''`, `x`] >> -fs [] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> -gs [] >> -QSPECL_X_ASSUM ``!n'. - n' < x ==> - !ms'4'. - FUNPOW_OPT m.trs n' ms = SOME ms'4' ==> - ~(n' > 0) \/ m.pc ms'4' NOTIN ls2`` [`n''`] >> -gs [] -QED - -Theorem weak_nonempty: - !m. - weak_model m ==> - !ms ls. - m.weak ms ls <> {} <=> (?ms'. m.weak ms ls ms') -Proof -rpt strip_tac >> -fs [GSYM pred_setTheory.MEMBER_NOT_EMPTY] >> -eq_tac >> (rpt strip_tac) >| [ - qexists_tac `x` >> - fs [pred_setTheory.IN_APP], - - qexists_tac `ms'` >> - fs [pred_setTheory.IN_APP] -] -QED - -Theorem weak_exec_exists: - !m. - weak_model m ==> - !ms ls ms'. - m.weak ms ls ms' <=> - weak_exec m ls ms = SOME ms' -Proof -rpt strip_tac >> -fs [weak_exec_def] >> -eq_tac >> ( - strip_tac -) >| [ - subgoal `m.weak ms ls = {ms'}` >- ( - fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING, pred_setTheory.IN_APP] >> - metis_tac [weak_unique_thm] - ) >> - fs [], - - metis_tac [pred_setTheory.CHOICE_DEF, pred_setTheory.IN_APP] -] -QED - -Theorem weak_exec_to_n: - !m. - weak_model m ==> - !ms ls ms'. - weak_exec m ls ms = SOME ms' <=> - weak_exec_n m ms ls 1 = SOME ms' -Proof -rpt strip_tac >> -fs [weak_exec_n_def, FUNPOW_OPT_def] -QED - -Theorem weak_inter: - !m. - weak_model m ==> - !ms ms' ms'' ls1 ls2. - DISJOINT ls1 ls2 ==> - m.weak ms ls2 ms' ==> - m.weak ms (ls1 UNION ls2) ms'' ==> - m.pc ms'' IN ls1 ==> - m.weak ms'' ls2 ms' -Proof -rpt strip_tac >> -(* ms goes to ms' in n steps. ms goes to ms'' in n' steps, for which: - * n'>n: impossible, by the first-encounter property - * n=n': impossible, since ms' is in ls2 and ms'' is in ls1 (disjoint sets) - * n' fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -subgoal `~(n'>n)` >- ( - QSPECL_X_ASSUM ``!n''. - n'' < n' /\ n'' > 0 ==> - ?ms'3'. - FUNPOW_OPT m.trs n'' ms = SOME ms'3' /\ m.pc ms'3' NOTIN ls1 /\ - m.pc ms'3' NOTIN ls2`` [`n`] >> - gs [] -) >> -subgoal `~(n'=n)` >- ( - strip_tac >> - gs [] >> - metis_tac [pred_setTheory.IN_DISJOINT] -) >> -subgoal `n'- ( - fs [] -) >> -qexists_tac `n-n'` >> -rpt strip_tac >| [ - fs [], - - (* by combining execution *) - irule FUNPOW_OPT_split2 >> - fs [] >> - qexists_tac `ms` >> - fs [], - - (* non-encounter in earlier steps *) - QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n' + n''`] >> - gs [] >> - qexists_tac `ms'''` >> - fs [] >> - metis_tac [FUNPOW_OPT_INTER, arithmeticTheory.ADD_COMM] -] -QED Theorem weak_partial_seq_rule_thm: !m l ls1 ls2 pre post. @@ -343,862 +187,6 @@ Definition weak_partial_loop_contract_def: (\ms. m.pc ms = l /\ invariant ms)) End -Theorem weak_least_trs: - !m ms ls ms'. - weak_model m ==> - ms <> ms' ==> - m.weak ms ls ms' ==> - ?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' ms = SOME ms') = SOME n' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -qexists_tac `n` >> -fs [whileTheory.OLEAST_EQ_SOME] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> -gs [] >> -subgoal `n' = 0` >- ( - fs [] -) >> -rw [] >> -gs [FUNPOW_OPT_compute] -QED - -Theorem weak_exec_n_prev: - !m. - weak_model m ==> - !ms ls ms' n_l. - weak_exec_n m ms ls (SUC n_l) = SOME ms' ==> - ?ms''. weak_exec_n m ms ls n_l = SOME ms'' /\ weak_exec_n m ms'' ls 1 = SOME ms' -Proof -rpt strip_tac >> -fs [weak_exec_n_def] >> -subgoal `SUC n_l > 0` >- ( - fs [] -) >> -imp_res_tac FUNPOW_OPT_prev_EXISTS >> -QSPECL_X_ASSUM ``!n'. _`` [`n_l`] >> -fs [] >> -Cases_on `n_l = 0` >- ( - gs [FUNPOW_OPT_compute] -) >> -irule FUNPOW_OPT_split >> -qexistsl_tac [`SUC n_l`, `ms`] >> -fs [arithmeticTheory.ADD1] -QED - -(* TODO: Useful? -Theorem weak_exec_n_split: -!m. weak_model m ==> -!s s' s'' ls n n'. -n > n' ==> -weak_exec_n m s ls n = SOME s' ==> -weak_exec_n m s ls (n - n') = SOME s'' ==> -weak_exec_n m s'' ls n' = SOME s' -Proof -cheat -QED -*) - -Theorem weak_exec_n_split2: -!m. weak_model m ==> -!s s' s'' ls n n'. -n >= n' ==> -weak_exec_n m s ls n' = SOME s'' ==> -weak_exec_n m s ls n = SOME s' ==> -weak_exec_n m s'' ls (n - n') = SOME s' -Proof -rpt strip_tac >> -fs [weak_exec_n_def] >> -Cases_on `n = n'` >- ( - fs [FUNPOW_OPT_compute] -) >> -subgoal `n > n'` >- ( - fs [] -) >> -metis_tac [FUNPOW_SUB, FUNPOW_OPT_def, arithmeticTheory.FUNPOW_ADD] -QED - - -Theorem weak_exec_n_cycle: - !m s s' ls n_l n_l'. - weak_model m ==> - n_l > 0 /\ weak_exec_n m s ls n_l = SOME s ==> - s <> s' ==> - (OLEAST n_l'. weak_exec_n m s ls n_l' = SOME s') = SOME n_l' ==> - n_l' < n_l -Proof -rpt strip_tac >> -CCONTR_TAC >> -Cases_on `n_l' = n_l` >- ( - fs [whileTheory.OLEAST_EQ_SOME] -) >> -subgoal `n_l' > n_l` >- ( - gs [] -) >> -subgoal `weak_exec_n m s ls (n_l' - n_l) = SOME s'` >- ( - irule weak_exec_n_split2 >> - fs [whileTheory.OLEAST_EQ_SOME] >> - qexists_tac `s` >> - fs [] -) >> -fs [whileTheory.OLEAST_EQ_SOME] >> -QSPECL_X_ASSUM ``!n_l''. n_l'' < n_l' ==> weak_exec_n m s ls n_l'' <> SOME s'`` [`n_l' - n_l`] >> -gs [] -QED - -(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' - * Let this rely on sub-lemma for incrementing weak_exec_n instead - * of reasoning on FUNPOW_OPT *) -Theorem weak_exec_incr_last: - !m. - weak_model m ==> - !ms ls ms' n_l ms''. - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> - m.weak ms' ls ms'' ==> - weak_exec_n m ms ls (SUC n_l) = SOME ms'' -Proof -rpt strip_tac >> -simp [weak_exec_n_def, arithmeticTheory.ADD1] >> -ONCE_REWRITE_TAC [arithmeticTheory.ADD_SYM] >> -irule FUNPOW_OPT_ADD_thm >> -qexists_tac `ms'` >> -fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> -simp [FUNPOW_OPT_def] >> -metis_tac [weak_exec_exists] -QED - -Theorem weak_exec_incr_first: - !m. - weak_model m ==> - !ms ls ms' n_l ms''. - m.weak ms ls ms' ==> - (OLEAST n. weak_exec_n m ms' ls n = SOME ms'') = SOME n_l ==> - weak_exec_n m ms ls (SUC n_l) = SOME ms'' -Proof -rpt strip_tac >> -simp [weak_exec_n_def, arithmeticTheory.ADD1] >> -irule FUNPOW_OPT_ADD_thm >> -qexists_tac `ms'` >> -fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def] >> -simp [FUNPOW_OPT_def] >> -metis_tac [weak_exec_exists] -QED - -Theorem weak_union_pc: - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms''. - m.weak ms ls2 ms' ==> - m.weak ms (ls1 UNION ls2) ms'' ==> - ms' <> ms'' ==> - m.pc ms'' IN ls1 -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> -Cases_on `n' > n` >- ( - QSPECL_X_ASSUM ``!n''. - n'' < n' /\ n'' > 0 ==> - ?ms'3'. - FUNPOW_OPT m.trs n'' ms = SOME ms'3' /\ m.pc ms'3' NOTIN ls1 /\ - m.pc ms'3' NOTIN ls2`` [`n`] >> - gs [] -) >> -Cases_on `n' = n` >- ( - gs [] -) >> -QSPECL_X_ASSUM ``!n'. - n' < n /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' ms = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n'`] >> -gs [] -QED - -Theorem weak_exec_n_add: -!m. weak_model m ==> -!s s' s'' ls n n'. -weak_exec_n m s ls n = SOME s' ==> -weak_exec_n m s' ls n' = SOME s'' ==> -weak_exec_n m s ls (n + n') = SOME s'' -Proof -rpt strip_tac >> -fs [weak_exec_n_def] >> -metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] -QED - -Theorem weak_exec_n_inter: - !m. - weak_model m ==> - !ms ms' ls1 ls2 n_l n_l'. - DISJOINT ls1 ls2 ==> - weak_exec_n m ms ls2 1 = SOME ms' ==> - (OLEAST n_l. weak_exec_n m ms (ls1 UNION ls2) n_l = SOME ms') = SOME n_l ==> - n_l' < n_l ==> - !ms''. - (OLEAST n_l. weak_exec_n m ms (ls1 UNION ls2) n_l = SOME ms'') = SOME n_l' ==> - weak_exec_n m ms'' ls2 1 = SOME ms' -Proof -ntac 7 strip_tac >> -Induct_on `n_l'` >- ( - rpt strip_tac >> - fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def, FUNPOW_OPT_compute] -) >> -rpt strip_tac >> -gs [whileTheory.OLEAST_EQ_SOME] >> -imp_res_tac weak_exec_n_prev >> -QSPECL_X_ASSUM ``!ms'3'. - weak_exec_n m ms (ls1 UNION ls2) n_l' = SOME ms'3' /\ - (!n_l. - n_l < n_l' ==> - weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms'3') ==> - weak_exec_n m ms'3' ls2 1 = SOME ms'`` [`ms'''`] >> -gs [] >> -subgoal `!n_l. n_l < n_l' ==> weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms'3'` >- ( - rpt strip_tac >> - QSPECL_X_ASSUM ``!n_l. - n_l < SUC n_l' ==> - weak_exec_n m ms (ls1 UNION ls2) n_l <> SOME ms''`` [`SUC n_l''`] >> - gs [] >> - metis_tac [weak_exec_n_add, arithmeticTheory.ADD1] -) >> -fs [] >> -(* TODO: Build together that you can proceed one weak transition to superset from ms''', - * and from the reach ms' whith next weak transition to ls2 *) -(* See reasoning in weak_inter *) -PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> -irule weak_inter >> -fs [] >> -qexistsl_tac [`ls1`, `ms'''`] >> -fs [] >> -subgoal `ms' <> ms''` >- ( -QSPECL_X_ASSUM ``!n_l'. - n_l' < n_l ==> weak_exec_n m ms (ls1 UNION ls2) n_l' <> SOME ms'`` [`SUC n_l'`] >> - gs [] -) >> -metis_tac [weak_union_pc] -QED - -Theorem weak_inter_exec: - !m. - weak_model m ==> - !ms ls1 ls2 n_l ms' ms''. - m.weak ms ls2 ms' ==> - DISJOINT ls1 ls2 ==> - (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> - SING (\n. n < n_l /\ weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') ==> - m.weak ms'' ls2 ms' -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) >> -irule weak_exec_n_inter >> -fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> -fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> -qexistsl_tac [`ls1`, `ms`, `n_l`, `x`] >> -fs [] >> -rpt strip_tac >> -QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms (ls1 UNION ls2) y = SOME ms'' ==> x = y`` [`n_l'`] >> -subgoal `n_l' < n_l` >- ( - gs [] -) >> -fs [] -QED - -Theorem weak_subset: - !m. weak_model m ==> - !ms ls1 ls2 ms'. - m.weak ms (ls1 UNION ls2) ms' ==> - ls1 SUBSET ls2 ==> - m.weak ms ls2 ms' -Proof -rpt strip_tac >> -fs [pred_setTheory.SUBSET_UNION_ABSORPTION] -QED - -Theorem weak_exec_n_OLEAST_equiv: - !m. weak_model m ==> - !s ls s'. - (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s') = SOME 1 ==> - m.weak s ls s' -Proof -rpt strip_tac >> -fs [whileTheory.OLEAST_EQ_SOME] >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) -QED - -(* Continuing weak_exec_n at s'', intermediately between s and s'' *) -Theorem weak_exec_n_OLEAST_inter: - !m. weak_model m ==> - !s s' s'' ls n' n'' n_l. - (OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s') = SOME n' ==> - (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' s = SOME s'') = SOME n'' ==> - n' > n'' ==> - (OLEAST n_l. n_l > 0 /\ weak_exec_n m s ls n_l = SOME s'') = SOME 1 ==> - (OLEAST n_l. weak_exec_n m s'' ls n_l = SOME s') = SOME n_l ==> - (OLEAST n_l. weak_exec_n m s ls n_l = SOME s') = SOME (n_l + 1) -Proof -rpt strip_tac >> -simp [whileTheory.OLEAST_EQ_SOME] >> -conj_tac >| [ - metis_tac [arithmeticTheory.ADD1, weak_exec_incr_first, weak_exec_n_OLEAST_equiv], - - fs [whileTheory.OLEAST_EQ_SOME] >> - subgoal `s <> s'` >- ( - QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`0`] >> - subgoal `0 < n'` >- ( - fs [] - ) >> - gs [FUNPOW_OPT_compute] - ) >> - subgoal `s'' <> s'` >- ( - QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''`] >> - gs [] - ) >> - subgoal `n_l > 0` >- ( - Cases_on `n_l = 0` >- ( - fs [weak_exec_n_def, FUNPOW_OPT_compute] - ) >> - fs [] - ) >> - `weak_exec_n m s ls 1 <> SOME s' /\ !n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'` suffices_by ( - rpt strip_tac >> - fs [] >> - QSPECL_X_ASSUM ``!n_l'. n_l' < n_l ==> weak_exec_n m s'' ls n_l' <> SOME s'`` [`n_l' - 1`] >> - gs [] >> - subgoal `n_l' >= 1` >- ( - Cases_on `n_l' = 0` >- ( - fs [weak_exec_n_def, FUNPOW_OPT_compute] - ) >> - fs [] - ) >> - metis_tac [weak_exec_n_split2] - ) >> - QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''`] >> - gs [] -] -QED - -Theorem weak_exec_1_superset_lemma: - !m. - weak_model m ==> - !ls1 ls2 s'. - !n n'. n' <= n ==> - n' >= 1 ==> - !s. m.weak s ls1 s' /\ ((OLEAST n'. FUNPOW_OPT m.trs n' s = SOME s') = SOME n') ==> - s <> s' ==> - ls1 SUBSET ls2 ==> - ?n_l. n_l >= 1 /\ (OLEAST n_l. weak_exec_n m s ls2 n_l = SOME s') = SOME n_l -Proof -ntac 5 strip_tac >> -Induct_on `n` >- ( - fs [] -) >> -rpt strip_tac >> -Cases_on `n' < SUC n` >- ( - QSPECL_X_ASSUM ``!n'. _`` [`n'`] >> - gs [] -) >> -subgoal `n' = SUC n` >- ( - fs [] -) >> -Cases_on `n = 0` >- ( - gs [] >> - subgoal `n' = 1` >- ( - fs [] - ) >> - fs [whileTheory.OLEAST_EQ_SOME] >> - qexists_tac `1` >> - fs [] >> - conj_tac >| [ - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - qexists_tac `1` >> - fs [] >> - metis_tac [weak_pc_in_thm, pred_setTheory.SUBSET_THM], - - rpt strip_tac >> - subgoal `n_l' = 0` >- ( - fs [] - ) >> - fs [weak_exec_n_def, FUNPOW_OPT_compute] - ] -) >> -(* 1. There exists a state s'' which we go to with weak-ls2 from s. (weak_superset_thm should suffice) - * s'' is reached with more trs than s': contradiction. - * s'' is reached with same amount of trs as s': s'' is s', proof completed - * with witness n_l''. - * s'' is reached with fewer trs than s': use induction hypothesis specialised for s'', then add - * numbers of weak-ls2 transitions together for the witness. *) -subgoal `?s''. (OLEAST n_l''. n_l'' > 0 /\ weak_exec_n m s ls2 n_l'' = SOME s'') = SOME 1` >- ( - subgoal `?ms''. m.weak s (ls1 UNION ls2) ms''` >- ( - metis_tac [weak_superset_thm] - ) >> - qexistsl_tac [`ms''`] >> - fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [weak_subset, weak_exec_to_n, weak_exec_exists] -) >> -subgoal `?n''. (OLEAST n''. n'' > 0 /\ FUNPOW_OPT m.trs n'' s = SOME s'') = SOME n''` >- ( - (* Since s'' is reached by non-zero weak transitions, there must be a (least) non-zero number of trs - * that reaches it *) - fs [whileTheory.OLEAST_EQ_SOME] >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - qexists_tac `n'''` >> - fs [] >> - rpt strip_tac >> - QSPECL_X_ASSUM ``!n'. - n' < n'3' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n''''`] >> - gs [] -) >> -(* s'' is reached with more trs than s': contradiction, s' would have been crossed *) -Cases_on `n'' > n'` >- ( - fs [whileTheory.OLEAST_EQ_SOME] >> - subgoal `m.weak s ls2 s''` >- ( - metis_tac [weak_exec_to_n, weak_exec_exists] - ) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - (* TODO: Make some kind of lemma here? *) - Q.SUBGOAL_THEN `n'4' = n''` (fn thm => fs [thm]) >- ( - Cases_on `n'' < n'4'` >- ( - QSPECL_X_ASSUM ``!n'. - n' < n'4' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n''`] >> - gs [] - ) >> - Cases_on `n'' > n'4'` >- ( - QSPECL_X_ASSUM ``!n'3'. - n'3' < n'' ==> FUNPOW_OPT m.trs n'3' s = SOME s'' ==> ~(n'3' > 0)`` [`n''''`] >> - gs [] - ) >> - fs [] - ) >> - (* TODO: Make some kind of lemma here? *) - Q.SUBGOAL_THEN `n'3' = n'` (fn thm => fs [thm]) >- ( - Cases_on `n' < n'3'` >- ( - QSPECL_X_ASSUM ``!n'. - n' < n'3' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> - gs [] - ) >> - Cases_on `n' > n'3'` >- ( - QSPECL_X_ASSUM ``!n'. - n' < n'3' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'''`] >> - gs [] - ) >> - fs [] - ) >> - QSPECL_X_ASSUM ``!n'. - n' < n'' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls2`` [`n'`] >> - gs [] >> - metis_tac [pred_setTheory.SUBSET_THM] -) >> -Cases_on `n'' = n'` >- ( - qexists_tac `1` >> - subgoal `s'' = s'` >- ( - fs [whileTheory.OLEAST_EQ_SOME] - ) >> - fs [whileTheory.OLEAST_EQ_SOME] >> - rpt strip_tac >> - subgoal `n_l = 0` >- ( - fs [] - ) >> - fs [weak_exec_n_def, FUNPOW_OPT_compute] -) >> -subgoal `n'' < n'` >- ( - fs [] -) >> -QSPECL_X_ASSUM ``!n'. _`` [`n' - n''`] >> -rfs [] >> -subgoal `n' <= n + n''` >- ( - gs [whileTheory.OLEAST_EQ_SOME] -) >> -fs [] >> -QSPECL_X_ASSUM ``!s'''. _`` [`s''`] >> -(* Should be possible to prove with some inter theorem... *) -subgoal `m.weak s'' ls1 s'` >- ( - (* Next state in s'' is s'... *) - PAT_ASSUM ``weak_model m`` (fn thm => simp [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - qexists_tac `n' - n''` >> - fs [] >> - rpt conj_tac >| [ - irule FUNPOW_OPT_split >> - qexistsl_tac [`n'`, `s`] >> - fs [whileTheory.OLEAST_EQ_SOME], - - metis_tac [weak_pc_in_thm], - - rpt strip_tac >> - fs [whileTheory.OLEAST_EQ_SOME] >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - (* TODO: Make some kind of lemma here? *) - subgoal `n'''' = n'` >- ( - Cases_on `n' < n'4'` >- ( - QSPECL_X_ASSUM ``!n'. - n' < n'4' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> - gs [] - ) >> - Cases_on `n' > n'4'` >- ( - QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n''''`] >> - gs [] - ) >> - fs [] - ) >> - gs [] >> - QSPECL_X_ASSUM ``!n'5'. - n'5' < n' /\ n'5' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n'5' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''' + n''`] >> - gs [] >> - qexists_tac `ms''` >> - fs [] >> - irule FUNPOW_OPT_split >> - qexistsl_tac [`n'' + n'3'`, `s`] >> - fs [] - ] -) >> -fs [] >> -subgoal `(OLEAST n'. FUNPOW_OPT m.trs n' s'' = SOME s') = SOME (n' - n'')` >- ( - fs [whileTheory.OLEAST_EQ_SOME] >> - conj_tac >| [ - irule FUNPOW_OPT_split >> - qexistsl_tac [`n'`, `s`] >> - fs [], - - rpt strip_tac >> - QSPECL_X_ASSUM ``!n''. n'' < n' ==> FUNPOW_OPT m.trs n'' s <> SOME s'`` [`n'' + n'''`] >> - gs [] >> - metis_tac [FUNPOW_OPT_ADD_thm, arithmeticTheory.ADD_COMM] - ] -) >> -fs [] >> -subgoal `s'' <> s'` >- ( - (* Since s'' NOTIN ls1, while s' IN ls1 *) - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP (fst $ EQ_IMP_RULE (Q.SPEC `m` weak_model_def)) thm]) >> - (* TODO: Make some kind of lemma here? *) - Q.SUBGOAL_THEN `n'3' = n'` (fn thm => fs [thm]) >- ( - Cases_on `n' < n'3'` >- ( - QSPECL_X_ASSUM ``!n'. - n' < n'3' /\ n' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n'`] >> - gs [whileTheory.OLEAST_EQ_SOME] - ) >> - Cases_on `n' > n'3'` >- ( - gs [whileTheory.OLEAST_EQ_SOME] - ) >> - fs [] - ) >> - QSPECL_X_ASSUM ``!n'5'. - n'5' < n' /\ n'5' > 0 ==> - ?ms''. FUNPOW_OPT m.trs n'5' s = SOME ms'' /\ m.pc ms'' NOTIN ls1`` [`n''`] >> - gs [whileTheory.OLEAST_EQ_SOME] >> - strip_tac >> - fs [] -) >> -fs [] >> -qexists_tac `1 + n_l` >> -fs [] >> -irule weak_exec_n_OLEAST_inter >> -fs [] >> -qexistsl_tac [`n''`, `s''`] >> -fs [] -QED - -(* TODO: Generalise this *) -(* TODO: Change weak_exec_n 1 to weak? *) -Theorem weak_exec_1_superset: - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - weak_exec_n m ms ls1 1 = SOME ms' ==> - ms <> ms' ==> - ls1 SUBSET ls2 ==> - ?n. n >= 1 /\ (OLEAST n. weak_exec_n m ms ls2 n = SOME ms') = SOME n -Proof -rpt strip_tac >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_to_n thm)]) >> -PAT_ASSUM ``weak_model m`` (fn thm => fs [GSYM (HO_MATCH_MP weak_exec_exists thm)]) >> -subgoal `?n'. n' > 0 /\ (OLEAST n'. FUNPOW_OPT m.trs n' ms = SOME ms') = SOME n'` >- ( - (* Since weak goes from ms to ms', there must be a least number of primitive transitions such that - * ms goes to ms' *) - metis_tac [weak_least_trs] -) >> -irule weak_exec_1_superset_lemma >> -fs [] >> -rpt strip_tac >| [ - qexists_tac `n'` >> - fs [], - - metis_tac [] -] -QED - -(* TODO: Strengthen conclusion to state either ms'' is ms', or pc is in ls2? *) -Theorem weak_exec_exists_superset: - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - m.weak ms ls1 ms' ==> - ?ms''. weak_exec m (ls1 UNION ls2) ms = SOME ms'' -Proof -rpt strip_tac >> -fs [weak_exec_def, weak_nonempty] >> -metis_tac [weak_superset_thm] -QED - -(* Note: ms <> ms' used to avoid proving case where least n is zero *) -Theorem weak_exec_n_exists_superset: - !m. - weak_model m ==> - !ms ls1 ls2 ms'. - m.weak ms ls1 ms' ==> - ms <> ms' ==> - ?n. (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n -Proof -rpt strip_tac >> -fs [whileTheory.OLEAST_EQ_SOME] >> -subgoal `weak_exec_n m ms ls1 1 = SOME ms'` >- ( - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_exists thm]) >> - PAT_ASSUM ``weak_model m`` (fn thm => fs [HO_MATCH_MP weak_exec_to_n thm]) -) >> -imp_res_tac weak_exec_1_superset >> -QSPECL_X_ASSUM ``!ls2. _`` [`ls1 UNION ls2`] >> -fs [] >> -qexists_tac `n` >> -fs [whileTheory.OLEAST_EQ_SOME] -QED - -Theorem weak_exec_least_nonzero: - !m. - weak_model m ==> - !ms ls ms' n_l. - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> - ms <> ms' ==> - n_l > 0 -Proof -rpt strip_tac >> -Cases_on `n_l` >> ( - fs [] -) >> -fs [whileTheory.OLEAST_EQ_SOME, weak_exec_n_def, FUNPOW_OPT_def] -QED - -Theorem weak_exec_sing_least_less: - !m. - weak_model m ==> - !ms ls ms' n_l. - SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms') ==> - ?n_l'. (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' /\ n_l' < n_l -Proof -rpt strip_tac >> -fs [pred_setTheory.SING_DEF, whileTheory.OLEAST_EQ_SOME] >> -qexists_tac `x` >> -rpt strip_tac >> ( - fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] -) >> -QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms' ==> x = y`` [`n`] >> -gs [] -QED - - -(* TODO: Technically, this doesn't need OLEAST for the encounter of ms' *) -Theorem weak_exec_incr_least: - !m. - weak_model m ==> - !ms ls ms' ms_e n_l n_l' ms''. - (OLEAST n. weak_exec_n m ms ls n = SOME ms_e) = SOME n_l ==> - ms'' <> ms_e ==> - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l' ==> - m.weak ms' ls ms'' ==> - SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms'') ==> - n_l' < n_l ==> - (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME (SUC n_l') -Proof -rpt strip_tac >> -imp_res_tac weak_exec_incr_last >> -fs [whileTheory.OLEAST_EQ_SOME] >> -rpt strip_tac >> -subgoal `SUC n_l' < n_l` >- ( - Cases_on `SUC n_l' = n_l` >- ( - fs [] - ) >> - fs [] -) >> -fs [pred_setTheory.SING_DEF] >> -fs [GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> -QSPECL_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms'' ==> x = y`` [`SUC n_l'`] >> -QSPECL_X_ASSUM ``!y. y < n_l /\ weak_exec_n m ms ls y = SOME ms'' ==> x = y`` [`n`] >> -gs [] -(* Due to SING (\n. n < n_l /\ weak_exec_n m ms ls n = SOME ms''), - * both weak_exec_n m ms ls (SUC n_l') and weak_exec_n m ms ls n - * can't lead to ms''. NOTE: Requires SUC n_l' < n_l *) -(* OK: If ms' was first encountered at n_l' weak iterations to ls, and - * if one additional weak transition to ls goes to ms'', then if - * ms'' is uniquely encountered before n_l weak transitions to ls and n_l - * is greater than n_l', then SUC n_l' must be the least number of weak transitions - * needed to reach ms'' *) -QED - -Theorem weak_exec_uniqueness: - !m. - weak_model m ==> - !ms ls ms' ms'' ms''' n_l n_l'. - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> - (OLEAST n. weak_exec_n m ms ls n = SOME ms'') = SOME n_l' ==> - n_l' < n_l ==> - m.weak ms'' ls ms''' ==> - ms''' <> ms' ==> - SING (\n_l''. n_l'' < n_l /\ weak_exec_n m ms ls n_l'' = SOME ms''') -Proof -rpt strip_tac >> -subgoal `weak_exec_n m ms ls (n_l' + 1) = SOME ms'3'` >- ( - irule weak_exec_n_add >> - fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [weak_exec_exists, weak_exec_to_n] -) >> -(* Suppose there exists some earlier encounter of ms''' *) -Cases_on `?n_l''. n_l'' < (n_l' + 1) /\ weak_exec_n m ms ls n_l'' = SOME ms'''` >- ( - fs [whileTheory.OLEAST_EQ_SOME] >> - subgoal `weak_exec_n m ms''' ls (n_l - (n_l' + 1)) = SOME ms'` >- ( - irule weak_exec_n_split2 >> - fs [] >> - qexists_tac `ms` >> - fs [] - ) >> - subgoal `weak_exec_n m ms ls (n_l'' + (n_l - (n_l' + 1))) = SOME ms'` >- ( - irule weak_exec_n_add >> - fs [] >> - qexists_tac `ms'3'` >> - fs [] - ) >> - QSPECL_ASSUM ``!n. n < n_l ==> weak_exec_n m ms ls n <> SOME ms'`` [`(n_l'' + (n_l - (n_l' + 1)))`] >> - gs [] -) >> -fs [] >> -(* If there were no earlier encounter of ms''', then the first encounter was at n_l' + 1 *) -subgoal `(OLEAST n_l. weak_exec_n m ms ls n_l = SOME ms''') = SOME (n_l' + 1)` >- ( - fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [] -) >> - -(* Suppose there exists some later encounter of ms''' *) -Cases_on `?n_l''. n_l'' > (n_l' + 1) /\ n_l'' < n_l /\ weak_exec_n m ms ls n_l'' = SOME ms'''` >- ( - fs [] >> - subgoal `(OLEAST n_l. weak_exec_n m ms''' ls n_l = SOME ms') = SOME (n_l - (n_l' + 1))` >- ( - fs [whileTheory.OLEAST_EQ_SOME] >> - rpt strip_tac >| [ - irule weak_exec_n_split2 >> - fs [] >> - qexists_tac `ms` >> - fs [], - - (* TODO: Prove the OLEAST part... *) - subgoal `weak_exec_n m ms ls ((n_l' + 1) + n_l'3') <> SOME ms'` >- ( - QSPECL_ASSUM ``!n. n < n_l ==> weak_exec_n m ms ls n <> SOME ms'`` [`(n_l' + 1) + n_l'3'`] >> - gs [] - ) >> - subgoal `weak_exec_n m ms ls ((n_l' + 1) + n_l'3') = SOME ms'` >- ( - irule weak_exec_n_add >> - fs [] - ) - ] - ) >> - subgoal `weak_exec_n m ms''' ls (n_l'' - (n_l' + 1)) = SOME ms'''` >- ( - irule weak_exec_n_split2 >> - fs [] >> - qexists_tac `ms` >> - fs [] - ) >> - (* By weak_exec_n_cycle *) - subgoal `(n_l - (n_l' + 1)) < (n_l'' - (n_l' + 1))` >- ( - irule weak_exec_n_cycle >> - fs [] >> - qexistsl_tac [`ls`, `m`, `ms'''`, `ms'`] >> - gs [whileTheory.OLEAST_EQ_SOME] - ) >> - gs [] -) >> -fs [] >> -gs [pred_setTheory.SING_DEF, GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> -qexists_tac `n_l' + 1` >> -rpt strip_tac >| [ - Cases_on `n_l' + 1 = n_l` >- ( - gvs [whileTheory.OLEAST_EQ_SOME] - ) >> - gs [], - - irule weak_exec_n_add >> - fs [] >> - qexists_tac `ms''` >> - fs [whileTheory.OLEAST_EQ_SOME] >> - metis_tac [weak_exec_exists, weak_exec_to_n], - - res_tac >> - gs [arithmeticTheory.EQ_LESS_EQ, arithmeticTheory.NOT_LESS] -] -QED - -Theorem weak_exec_unique_start: - !m. - weak_model m ==> - !ms ls ms' n_l. - (OLEAST n. weak_exec_n m ms ls n = SOME ms') = SOME n_l ==> - ms <> ms' ==> - SING (\n_l'. n_l' < n_l /\ weak_exec_n m ms ls n_l' = SOME ms) -Proof -rpt strip_tac >> -gs [pred_setTheory.SING_DEF, GSYM pred_setTheory.UNIQUE_MEMBER_SING] >> -qexists_tac `0` >> -rpt strip_tac >| [ - Cases_on `n_l = 0` >> ( - fs [weak_exec_n_def, FUNPOW_OPT_compute, whileTheory.OLEAST_EQ_SOME] - ), - - fs [weak_exec_n_def, FUNPOW_OPT_compute], - - Cases_on `y > 0` >- ( - imp_res_tac weak_exec_n_cycle >> - fs [] - ) >> - fs [] -] -QED - -(* Uses the fact that exit labels are disjoint from loop point to know that - * we have not yet exited the loop after another weak transition, i.e. the - * number of loops is still less than n_l *) -Theorem weak_exec_less_incr_superset: - !m. - weak_model m ==> - !ms ls1 ls2 ms' ms'' ms''' n_l n_l'. - DISJOINT ls1 ls2 ==> - (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms') = SOME n_l ==> - m.pc ms' IN ls2 ==> - (OLEAST n. weak_exec_n m ms (ls1 UNION ls2) n = SOME ms'') = SOME n_l' ==> - n_l' < n_l ==> - m.weak ms'' (ls1 UNION ls2) ms''' ==> - m.pc ms''' NOTIN ls2 ==> - SUC n_l' < n_l -Proof -rpt strip_tac >> -Cases_on `SUC n_l' = n_l` >- ( - subgoal `ms''' = ms'` >- ( - subgoal `weak_exec_n m ms (ls1 UNION ls2) (SUC n_l') = SOME ms'''` >- ( - metis_tac [weak_exec_incr_last] - ) >> - gs [whileTheory.OLEAST_EQ_SOME] - ) >> - fs [] -) >> -fs [] -QED - - (* Invariant: *) (* TODO: Is SING useful enough or do we need LEAST? *) val invariant = ``\s. (SING (\n. n < n_l /\ weak_exec_n m ms ({l} UNION le) n = SOME s)) /\ invariant s``; From 2ae95c8644c4d5ddc133d31f9f909103c23cf759 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 31 May 2022 11:16:41 +0200 Subject: [PATCH 0115/1015] Small fix --- src/theory/tools/comp/bir_wm_instScript.sml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/theory/tools/comp/bir_wm_instScript.sml b/src/theory/tools/comp/bir_wm_instScript.sml index 5a5bc2c2d..e040ae5a0 100644 --- a/src/theory/tools/comp/bir_wm_instScript.sml +++ b/src/theory/tools/comp/bir_wm_instScript.sml @@ -17,6 +17,7 @@ open bir_typing_progTheory; open bir_exp_tautologiesTheory; open bir_htTheory; +open abstract_hoare_logic_auxTheory; open abstract_hoare_logicTheory; open abstract_simp_hoare_logicTheory; From dc751f6e9b63bdbaa73770d0ec95fd7aa8f50a46 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Tue, 31 May 2022 17:13:27 +0200 Subject: [PATCH 0116/1015] Fixed weak_partial_subset_rule_thm --- .../abstract_hoare_logic_partialScript.sml | 23 ++++--------------- 1 file changed, 4 insertions(+), 19 deletions(-) diff --git a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml index 1c9805230..9614be997 100644 --- a/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml +++ b/src/theory/abstract_hoare_logic/abstract_hoare_logic_partialScript.sml @@ -54,34 +54,19 @@ rpt strip_tac >> metis_tac [weak_pc_in_thm] QED -(* TODO Fix this... Theorem weak_partial_subset_rule_thm: !m. !l ls1 ls2 pre post. weak_model m ==> - (!ms. post ms ==> (~(m.pc ms IN ls2))) ==> + (!ms. post ms ==> ~(m.pc ms IN ls2)) ==> abstract_partial_jgmt m l (ls1 UNION ls2) pre post ==> abstract_partial_jgmt m l ls1 pre post Proof rpt strip_tac >> -rfs [abstract_partial_jgmt_def] >> +fs [abstract_partial_jgmt_def] >> rpt strip_tac >> -QSPECL_ASSUM ``!ms ms'. _`` [`ms`, `ms'`] >> -rfs [] >> -Cases_on `m.weak ms (ls1 UNION ls2) ms'` >- ( - fs [] -) >> -subgoal `?n. FUNPOW_OPT m.trs n ms = SOME ms'` >- ( - metis_tac [weak_model_def] -) >> -(* TODO: Fix this -IMP_RES_TAC weak_intermediate_labels >> -QSPECL_X_ASSUM ``!ms ms'. _`` [`ms`, `ms''`] >> -rfs [] >> -metis_tac [] -*) -cheat +imp_res_tac weak_superset_thm >> +metis_tac [pred_setTheory.UNION_COMM, weak_union_thm, weak_unique_thm] QED -*) Theorem weak_partial_conj_rule_thm: !m. From d3c8087260fbf81c141e539615cd63126ce3c778 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 16 Jun 2022 17:07:09 +0200 Subject: [PATCH 0117/1015] Updated tutorial with clearer naming conventions and documentation --- examples/tutorial/1-code/README.md | 9 ++++----- examples/tutorial/2-lift/README.md | 2 +- ...BinaryScript.sml => bir_prog_add_regScript.sml} | 2 +- ...sBinaryScript.sml => bir_prog_freuseScript.sml} | 6 +++--- ...2BinaryScript.sml => bir_prog_mutrecScript.sml} | 6 +++--- examples/tutorial/2-lift/tutorial_liftScript.sml | 2 +- examples/tutorial/3-exec/exec.sml | 2 +- ...{tutorial_wpScript.sml => add_reg_wpScript.sml} | 4 ++-- ...orialExtra_wpScript.sml => freuse_wpScript.sml} | 14 +++++++------- ...rialExtra2_wpScript.sml => mutrec_wpScript.sml} | 14 +++++++------- ...utorial_smtScript.sml => add_reg_smtScript.sml} | 4 ++-- ...ialExtra_smtScript.sml => freuse_smtScript.sml} | 4 ++-- ...alExtra2_smtScript.sml => mutrec_smtScript.sml} | 4 ++-- examples/tutorial/7-composition/README.md | 8 +------- ...ionScript.sml => add_reg_compositionScript.sml} | 8 ++++---- ...tionScript.sml => freuse_compositionScript.sml} | 6 +++--- ...tionScript.sml => mutrec_compositionScript.sml} | 8 ++++---- .../7-composition/tutorial_backliftingScript.sml | 6 +++--- examples/tutorial/README.md | 10 +++++++--- 19 files changed, 58 insertions(+), 61 deletions(-) rename examples/tutorial/2-lift/{examplesBinaryScript.sml => bir_prog_add_regScript.sml} (90%) rename examples/tutorial/2-lift/{birExamplesBinaryScript.sml => bir_prog_freuseScript.sml} (94%) rename examples/tutorial/2-lift/{birExamples2BinaryScript.sml => bir_prog_mutrecScript.sml} (95%) rename examples/tutorial/5-wp/{tutorial_wpScript.sml => add_reg_wpScript.sml} (99%) rename examples/tutorial/5-wp/{tutorialExtra_wpScript.sml => freuse_wpScript.sml} (95%) rename examples/tutorial/5-wp/{tutorialExtra2_wpScript.sml => mutrec_wpScript.sml} (95%) rename examples/tutorial/6-smt/{tutorial_smtScript.sml => add_reg_smtScript.sml} (98%) rename examples/tutorial/6-smt/{tutorialExtra_smtScript.sml => freuse_smtScript.sml} (96%) rename examples/tutorial/6-smt/{tutorialExtra2_smtScript.sml => mutrec_smtScript.sml} (97%) rename examples/tutorial/7-composition/{tutorial_compositionScript.sml => add_reg_compositionScript.sml} (96%) rename examples/tutorial/7-composition/{tutorialExtra_compositionScript.sml => freuse_compositionScript.sml} (98%) rename examples/tutorial/7-composition/{tutorialExtra2_compositionScript.sml => mutrec_compositionScript.sml} (98%) diff --git a/examples/tutorial/1-code/README.md b/examples/tutorial/1-code/README.md index 846297245..1ff37560e 100644 --- a/examples/tutorial/1-code/README.md +++ b/examples/tutorial/1-code/README.md @@ -60,14 +60,13 @@ The produced binary consists of four blocks # Some notes on the examples The `add_reg` function has some properties that make our analysis simpler: -* there are no indirect jumps. We cannot currently automatically - analyse code with indirect jumps, since the weakest precondition - algorithm requires a static control flow graph. +* there are no indirect jumps. See `examples/tutorial/ijr` for an example + of indirect jump resolution. * there are no multiplications among variables: non-linear arithmetic is an hard problem for SMT solvers, therefore analysing the algorithm would require to verify some support theorems that can be used as axioms in Z3 -* memory is not updated. This dramatically reduce the problem size in - Z3. A more detailed discussion regarding problems to handle memory +* memory is not updated. This dramatically reduces the problem size in + Z3. A more detailed discussion regarding problems of handling memory accesses is in section 5 and 6. diff --git a/examples/tutorial/2-lift/README.md b/examples/tutorial/2-lift/README.md index 419848cdb..19298108e 100644 --- a/examples/tutorial/2-lift/README.md +++ b/examples/tutorial/2-lift/README.md @@ -15,7 +15,7 @@ The parameters of this functions are: Transpilation of the example is executed using the command `make examples/tutorial/2-lift`, which transpiles the program and generates -the corresponding `examplesBinaryTheory`. +the corresponding `bir_prog_add_regTheory`. File `tutorial_liftScript.sml` demonstrates the theorems obtained by the transpiler. diff --git a/examples/tutorial/2-lift/examplesBinaryScript.sml b/examples/tutorial/2-lift/bir_prog_add_regScript.sml similarity index 90% rename from examples/tutorial/2-lift/examplesBinaryScript.sml rename to examples/tutorial/2-lift/bir_prog_add_regScript.sml index 9fffcc0ac..a1951ae26 100644 --- a/examples/tutorial/2-lift/examplesBinaryScript.sml +++ b/examples/tutorial/2-lift/bir_prog_add_regScript.sml @@ -6,7 +6,7 @@ val _ = Parse.current_backend := PPBackEnd.vt100_terminal; val _ = set_trace "bir_inst_lifting.DEBUG_LEVEL" 2; -val _ = new_theory "examplesBinary"; +val _ = new_theory "bir_prog_add_reg"; val _ = lift_da_and_store "add_reg" "../1-code/src/add_reg.da" diff --git a/examples/tutorial/2-lift/birExamplesBinaryScript.sml b/examples/tutorial/2-lift/bir_prog_freuseScript.sml similarity index 94% rename from examples/tutorial/2-lift/birExamplesBinaryScript.sml rename to examples/tutorial/2-lift/bir_prog_freuseScript.sml index 2d7e51160..d4ddbb34f 100644 --- a/examples/tutorial/2-lift/birExamplesBinaryScript.sml +++ b/examples/tutorial/2-lift/bir_prog_freuseScript.sml @@ -1,10 +1,10 @@ open HolKernel boolLib liteLib simpLib Parse bossLib; -val _ = new_theory "birExamplesBinary"; +val _ = new_theory "bir_prog_freuse"; -val bprog_add_times_two_def = Define ` - bprog_add_times_two = (BirProgram +val freuse_def = Define ` + freuse = (BirProgram [ (* add times two *) <|bb_label := BL_Address (Imm32 0x000w); diff --git a/examples/tutorial/2-lift/birExamples2BinaryScript.sml b/examples/tutorial/2-lift/bir_prog_mutrecScript.sml similarity index 95% rename from examples/tutorial/2-lift/birExamples2BinaryScript.sml rename to examples/tutorial/2-lift/bir_prog_mutrecScript.sml index 3a7a07fcb..fd4301bc1 100644 --- a/examples/tutorial/2-lift/birExamples2BinaryScript.sml +++ b/examples/tutorial/2-lift/bir_prog_mutrecScript.sml @@ -1,10 +1,10 @@ open HolKernel boolLib liteLib simpLib Parse bossLib; -val _ = new_theory "birExamples2Binary"; +val _ = new_theory "bir_prog_mutrec"; -val bprog_is_even_odd_def = Define ` - bprog_is_even_odd = (BirProgram +val mutrec_def = Define ` + mutrec = (BirProgram [ (* is_even *) <|bb_label := BL_Address (Imm32 0x000w); diff --git a/examples/tutorial/2-lift/tutorial_liftScript.sml b/examples/tutorial/2-lift/tutorial_liftScript.sml index d3408ad13..25c02202c 100644 --- a/examples/tutorial/2-lift/tutorial_liftScript.sml +++ b/examples/tutorial/2-lift/tutorial_liftScript.sml @@ -19,7 +19,7 @@ open PPBackEnd Parse open bir_inst_liftingHelpersLib; (* ================================================ *) -open examplesBinaryTheory; +open bir_prog_add_regTheory; val _ = new_theory "tutorial_lift"; diff --git a/examples/tutorial/3-exec/exec.sml b/examples/tutorial/3-exec/exec.sml index bcb1554db..8a8d2183e 100644 --- a/examples/tutorial/3-exec/exec.sml +++ b/examples/tutorial/3-exec/exec.sml @@ -1,6 +1,6 @@ open HolKernel Parse; -open examplesBinaryTheory; +open bir_prog_add_regTheory; open bir_exec_envLib; open bir_execLib; diff --git a/examples/tutorial/5-wp/tutorial_wpScript.sml b/examples/tutorial/5-wp/add_reg_wpScript.sml similarity index 99% rename from examples/tutorial/5-wp/tutorial_wpScript.sml rename to examples/tutorial/5-wp/add_reg_wpScript.sml index 3b42700f9..ab4e5f3c4 100644 --- a/examples/tutorial/5-wp/tutorial_wpScript.sml +++ b/examples/tutorial/5-wp/add_reg_wpScript.sml @@ -20,13 +20,13 @@ open HolBACoreSimps; open bir_exp_to_wordsLib bslSyntax; (* From examples: *) -open examplesBinaryTheory; +open bir_prog_add_regTheory; open tutorial_bir_to_armTheory; (* From HOL4: *) open finite_mapSyntax pairSyntax pred_setSyntax; -val _ = new_theory "tutorial_wp"; +val _ = new_theory "add_reg_wp"; (* You may install the BIR pretty printers to get syntax * highlighting for matching pairs of parantheses: diff --git a/examples/tutorial/5-wp/tutorialExtra_wpScript.sml b/examples/tutorial/5-wp/freuse_wpScript.sml similarity index 95% rename from examples/tutorial/5-wp/tutorialExtra_wpScript.sml rename to examples/tutorial/5-wp/freuse_wpScript.sml index b02b876f0..57afa4c57 100644 --- a/examples/tutorial/5-wp/tutorialExtra_wpScript.sml +++ b/examples/tutorial/5-wp/freuse_wpScript.sml @@ -20,14 +20,14 @@ open HolBACoreSimps; open bir_exp_to_wordsLib bslSyntax; (* From examples: *) -open birExamplesBinaryTheory; +open bir_prog_freuseTheory; (* From HOL4: *) open finite_mapSyntax pairSyntax pred_setSyntax; -val _ = new_theory "tutorialExtra_wp"; +val _ = new_theory "freuse_wp"; -val prog_tm = (lhs o concl) bprog_add_times_two_def; +val prog_tm = (lhs o concl) freuse_def; (* Sections and hoare triples: @@ -131,7 +131,7 @@ val postcond_tm = ``\l. if (l = BL_Address (Imm32 0x104w)) then bir_att_sec_add_1_post v1 v2 v3 else bir_exp_false``; -val defs = [bprog_add_times_two_def, bir_att_sec_add_1_post_def, +val defs = [freuse_def, bir_att_sec_add_1_post_def, bir_exp_false_def, BType_Bool_def]; val (bir_att_sec_add_1_ht, bir_att_sec_add_1_wp_tm) = @@ -152,7 +152,7 @@ val postcond_tm = ``\l. if (l = BL_Address (Imm32 0x100w)) then bir_att_sec_call_1_post v1 v2 else bir_exp_false``; -val defs = [bprog_add_times_two_def, bir_att_sec_call_1_post_def, +val defs = [freuse_def, bir_att_sec_call_1_post_def, bir_exp_false_def, BType_Bool_def]; val (bir_att_sec_call_1_ht, bir_att_sec_call_1_wp_tm) = @@ -173,7 +173,7 @@ val postcond_tm = ``\l. if (l = BL_Address (Imm32 0x100w)) then bir_att_sec_call_2_post v1 else bir_exp_false``; -val defs = [bprog_add_times_two_def, bir_att_sec_call_2_post_def, +val defs = [freuse_def, bir_att_sec_call_2_post_def, bir_exp_false_def, BType_Bool_def]; val (bir_att_sec_call_2_ht, bir_att_sec_call_2_wp_tm) = @@ -208,7 +208,7 @@ val postcond_tm = ``\l. if (l = BL_Address (Imm32 v3)) else bir_exp_false``; val prog_block_addr = ``(Imm32 0x104w)``; -val prog_tm = ``bprog_add_times_two``; +val prog_tm = ``freuse``; val prog_block = (snd o dest_eq o concl o EVAL) ``(SND (THE (bir_get_program_block_info_by_label ^prog_tm (BL_Address ^prog_block_addr))))``; val ret_block_specl = [prog_tm, prog_block, ``BL_Address ^prog_block_addr``, ``Imm32 v3``, ``v4s:bir_label_t->bool``, ``(BVar "t" (BType_Imm Bit32))``, ``bir_att_sec_add_2_post v1 v2``]; val ret_block_thm = diff --git a/examples/tutorial/5-wp/tutorialExtra2_wpScript.sml b/examples/tutorial/5-wp/mutrec_wpScript.sml similarity index 95% rename from examples/tutorial/5-wp/tutorialExtra2_wpScript.sml rename to examples/tutorial/5-wp/mutrec_wpScript.sml index a75e4c936..10141de75 100644 --- a/examples/tutorial/5-wp/tutorialExtra2_wpScript.sml +++ b/examples/tutorial/5-wp/mutrec_wpScript.sml @@ -20,14 +20,14 @@ open HolBACoreSimps; open bir_exp_to_wordsLib bslSyntax; (* From examples: *) -open birExamples2BinaryTheory; +open bir_prog_mutrecTheory; (* From HOL4: *) open finite_mapSyntax pairSyntax pred_setSyntax; -val _ = new_theory "tutorialExtra2_wp"; +val _ = new_theory "mutrec_wp"; -val prog_tm = (lhs o concl) bprog_is_even_odd_def; +val prog_tm = (lhs o concl) mutrec_def; (* Sections and hoare triples: @@ -158,7 +158,7 @@ val first_block_label_tm = ``BL_Address (Imm32 0x000w)``; val ending_set = ``{BL_Address (Imm32 0x000w); BL_Address (Imm32 0x200w); BL_Address (Imm32 0x204w)}``; val postcond_tm = ``bir_ieo_sec_iseven_loop_post v1 v``; -val defs = [bprog_is_even_odd_def, bir_ieo_sec_iseven_loop_post_def, +val defs = [mutrec_def, bir_ieo_sec_iseven_loop_post_def, bir_ieo_post_odd_def, bir_ieo_post_even_def, bir_ieo_invariant_def, bir_ieo_condition_def, bir_ieo_variant_def, bir_exp_false_def, BType_Bool_def]; @@ -180,7 +180,7 @@ val first_block_label_tm = ``BL_Address (Imm32 0x000w)``; val ending_set = ``{BL_Address (Imm32 0x000w); BL_Address (Imm32 0x200w); BL_Address (Imm32 0x204w)}``; val postcond_tm = ``bir_ieo_sec_iseven_exit_post v1``; -val defs = [bprog_is_even_odd_def, bir_ieo_sec_iseven_exit_post_def, +val defs = [mutrec_def, bir_ieo_sec_iseven_exit_post_def, bir_ieo_post_odd_def, bir_ieo_post_even_def, bir_ieo_invariant_def, bir_exp_false_def, BType_Bool_def]; @@ -201,7 +201,7 @@ val first_block_label_tm = ``BL_Address (Imm32 0x100w)``; val ending_set = ``{BL_Address (Imm32 0x100w); BL_Address (Imm32 0x200w); BL_Address (Imm32 0x204w)}``; val postcond_tm = ``bir_ieo_sec_isodd_loop_post v1 v``; -val defs = [bprog_is_even_odd_def, bir_ieo_sec_isodd_loop_post_def, +val defs = [mutrec_def, bir_ieo_sec_isodd_loop_post_def, bir_ieo_post_odd_def, bir_ieo_post_even_def, bir_ieo_invariant_def, bir_ieo_condition_def, bir_ieo_variant_def, bir_exp_false_def, BType_Bool_def]; @@ -223,7 +223,7 @@ val first_block_label_tm = ``BL_Address (Imm32 0x100w)``; val ending_set = ``{BL_Address (Imm32 0x100w); BL_Address (Imm32 0x200w); BL_Address (Imm32 0x204w)}``; val postcond_tm = ``bir_ieo_sec_isodd_exit_post v1``; -val defs = [bprog_is_even_odd_def, bir_ieo_sec_isodd_exit_post_def, +val defs = [mutrec_def, bir_ieo_sec_isodd_exit_post_def, bir_ieo_post_odd_def, bir_ieo_post_even_def, bir_ieo_invariant_def, bir_exp_false_def, BType_Bool_def]; diff --git a/examples/tutorial/6-smt/tutorial_smtScript.sml b/examples/tutorial/6-smt/add_reg_smtScript.sml similarity index 98% rename from examples/tutorial/6-smt/tutorial_smtScript.sml rename to examples/tutorial/6-smt/add_reg_smtScript.sml index 775a8c358..a40fa4a19 100644 --- a/examples/tutorial/6-smt/tutorial_smtScript.sml +++ b/examples/tutorial/6-smt/add_reg_smtScript.sml @@ -17,7 +17,7 @@ in () end else (); (* From examples: *) open tutorial_bir_to_armTheory; -open tutorial_wpTheory; +open add_reg_wpTheory; open tutorial_smtSupportLib; if !Globals.interactive then let @@ -35,7 +35,7 @@ if !Globals.interactive then let *) in () end else (); -val _ = new_theory "tutorial_smt"; +val _ = new_theory "add_reg_smt"; (*****************************************************************************) (* 1.1. Prove Hoare triples *) diff --git a/examples/tutorial/6-smt/tutorialExtra_smtScript.sml b/examples/tutorial/6-smt/freuse_smtScript.sml similarity index 96% rename from examples/tutorial/6-smt/tutorialExtra_smtScript.sml rename to examples/tutorial/6-smt/freuse_smtScript.sml index c71633df3..48fe6a6a9 100644 --- a/examples/tutorial/6-smt/tutorialExtra_smtScript.sml +++ b/examples/tutorial/6-smt/freuse_smtScript.sml @@ -8,11 +8,11 @@ open bir_exp_to_wordsLib bslSyntax; open pretty_exnLib; (* From examples: *) -open tutorialExtra_wpTheory; +open freuse_wpTheory; open tutorial_smtSupportLib; -val _ = new_theory "tutorialExtra_smt"; +val _ = new_theory "freuse_smt"; diff --git a/examples/tutorial/6-smt/tutorialExtra2_smtScript.sml b/examples/tutorial/6-smt/mutrec_smtScript.sml similarity index 97% rename from examples/tutorial/6-smt/tutorialExtra2_smtScript.sml rename to examples/tutorial/6-smt/mutrec_smtScript.sml index 649a12163..40987391c 100644 --- a/examples/tutorial/6-smt/tutorialExtra2_smtScript.sml +++ b/examples/tutorial/6-smt/mutrec_smtScript.sml @@ -8,11 +8,11 @@ open bir_exp_to_wordsLib bslSyntax; open pretty_exnLib; (* From examples: *) -open tutorialExtra2_wpTheory; +open mutrec_wpTheory; open tutorial_smtSupportLib; -val _ = new_theory "tutorialExtra2_smt"; +val _ = new_theory "mutrec_smt"; diff --git a/examples/tutorial/7-composition/README.md b/examples/tutorial/7-composition/README.md index 5ad41e190..532d9725c 100644 --- a/examples/tutorial/7-composition/README.md +++ b/examples/tutorial/7-composition/README.md @@ -4,10 +4,4 @@ In the last step, we finally proved the Hoare triples with the preconditions given in step 4. In this step, we will go all the way and compose all the Hoare triples together to one contract on the entire program. Then, we will prove equivalence of this to the ARM contract we originally phrased. Note that this means that everything BIR-related is outside the TCB. We only need to trust that the definitions in the ARM contract are valid. -## Composition - -TODO - -## Backlifting - -TODO \ No newline at end of file +The final theorems for the `add_reg`, `freuse` and `mutrec` examples are `arm_add_reg_contract_thm` in `tutorial_backliftingScript`, `bir_att_ct` in `freuse_compositionScript` and `bir_ieo_is_odd_ht` and `bir_ieo_is_even_ht` in `mutrec_compositionScript`, respectively. diff --git a/examples/tutorial/7-composition/tutorial_compositionScript.sml b/examples/tutorial/7-composition/add_reg_compositionScript.sml similarity index 96% rename from examples/tutorial/7-composition/tutorial_compositionScript.sml rename to examples/tutorial/7-composition/add_reg_compositionScript.sml index bf44aace5..b219de0b3 100644 --- a/examples/tutorial/7-composition/tutorial_compositionScript.sml +++ b/examples/tutorial/7-composition/add_reg_compositionScript.sml @@ -19,9 +19,9 @@ open PPBackEnd Parse open bir_inst_liftingHelpersLib; (* ================================================ *) -open examplesBinaryTheory; -open tutorial_bir_to_armTheory tutorial_wpTheory - tutorial_smtTheory; +open bir_prog_add_regTheory; +open tutorial_bir_to_armTheory add_reg_wpTheory + add_reg_smtTheory; open bir_wp_interfaceLib; @@ -29,7 +29,7 @@ open bir_compositionLib; open bslSyntax; -val _ = new_theory "tutorial_composition"; +val _ = new_theory "add_reg_composition"; (****************************************************************) (* Step 0: *) diff --git a/examples/tutorial/7-composition/tutorialExtra_compositionScript.sml b/examples/tutorial/7-composition/freuse_compositionScript.sml similarity index 98% rename from examples/tutorial/7-composition/tutorialExtra_compositionScript.sml rename to examples/tutorial/7-composition/freuse_compositionScript.sml index 9e0652cfd..40e470c36 100644 --- a/examples/tutorial/7-composition/tutorialExtra_compositionScript.sml +++ b/examples/tutorial/7-composition/freuse_compositionScript.sml @@ -21,8 +21,8 @@ open bir_inst_liftingHelpersLib; open bir_wm_instTheory; -open birExamplesBinaryTheory; -open tutorialExtra_wpTheory tutorialExtra_smtTheory; +open bir_prog_freuseTheory; +open freuse_wpTheory freuse_smtTheory; open bir_wp_interfaceLib; @@ -30,7 +30,7 @@ open bir_compositionLib; open HolBACoreSimps; -val _ = new_theory "tutorialExtra_composition"; +val _ = new_theory "freuse_composition"; val bir_att_sec_add_1_comp_ct = (* TODO: Why not use diff --git a/examples/tutorial/7-composition/tutorialExtra2_compositionScript.sml b/examples/tutorial/7-composition/mutrec_compositionScript.sml similarity index 98% rename from examples/tutorial/7-composition/tutorialExtra2_compositionScript.sml rename to examples/tutorial/7-composition/mutrec_compositionScript.sml index df18c6313..4efce7a26 100644 --- a/examples/tutorial/7-composition/tutorialExtra2_compositionScript.sml +++ b/examples/tutorial/7-composition/mutrec_compositionScript.sml @@ -5,9 +5,9 @@ open bir_wm_instTheory; open bir_compositionLib; open bir_wp_interfaceLib; -open birExamples2BinaryTheory; -open tutorialExtra2_wpTheory; -open tutorialExtra2_smtTheory; +open bir_prog_mutrecTheory; +open mutrec_wpTheory; +open mutrec_smtTheory; open bir_auxiliaryLib; @@ -15,7 +15,7 @@ open HolBACoreSimps; open HolBASimps; open abstract_hoare_logicSimps; -val _ = new_theory "tutorialExtra2_composition"; +val _ = new_theory "mutrec_composition"; (* =============================================================== *) diff --git a/examples/tutorial/7-composition/tutorial_backliftingScript.sml b/examples/tutorial/7-composition/tutorial_backliftingScript.sml index c6302c2ec..e8f8ea6a3 100644 --- a/examples/tutorial/7-composition/tutorial_backliftingScript.sml +++ b/examples/tutorial/7-composition/tutorial_backliftingScript.sml @@ -1,7 +1,7 @@ open HolKernel Parse boolLib bossLib; -open examplesBinaryTheory tutorial_bir_to_armTheory - tutorial_compositionTheory; +open bir_prog_add_regTheory tutorial_bir_to_armTheory + add_reg_compositionTheory; open bir_backlifterLib; @@ -33,7 +33,7 @@ get_arm8_contract_sing bir_add_reg_ct ``bir_add_reg_progbin`` ``arm8_add_reg_pre [bir_add_reg_contract_1_pre_def, bir_add_reg_pre_def] bir_add_reg_contract_1_pre_def arm8_pre_imp_bir_pre_thm [bir_add_reg_contract_4_post_def] arm8_post_imp_bir_post_thm - examplesBinaryTheory.bir_add_reg_arm8_lift_THM + bir_prog_add_regTheory.bir_add_reg_arm8_lift_THM ); val _ = export_theory(); diff --git a/examples/tutorial/README.md b/examples/tutorial/README.md index 447bb6dac..fa189df31 100644 --- a/examples/tutorial/README.md +++ b/examples/tutorial/README.md @@ -1,10 +1,14 @@ -# The HolBA tutorial with `add_reg` +# The HolBA tutorial ## Overview -A diagram of the tutorial flow with theorem connections/relations goes here. +The tutorial features verification of three examples: -A diagram of the binary control flow goes here. +* `add_reg`, a program that incrementally adds one register to another. This demonstrates the full HolBA workflow: from transpilation of an ARMv8 binary to BIR, to transfer of the BIR contract to ARMv8. +* `mutrec`, a program using mutually recursive functions to compute the parity of an integer. +* `freuse`, a program calling a function twice. + +The different directories contain the different stages of verification (with `3-exec` and `8-symbexec` added in as bonus experiments). `7-composition` contains the theorems stating the final contracts. ## Build system From 145b703a727223e814e88a8e53a02ca619658ed4 Mon Sep 17 00:00:00 2001 From: Didrik Lundberg Date: Thu, 16 Jun 2022 18:26:39 +0200 Subject: [PATCH 0118/1015] Fixes to tutorial resulting from change in naming conventions --- .../7-composition/freuse_compositionScript.sml | 2 +- .../7-composition/mutrec_compositionScript.sml | 13 +++++++------ examples/tutorial/test-composition.sml | 12 ++++++------ src/tools/comp/bir_compositionLib.sml | 4 ++-- 4 files changed, 16 insertions(+), 15 deletions(-) diff --git a/examples/tutorial/7-composition/freuse_compositionScript.sml b/examples/tutorial/7-composition/freuse_compositionScript.sml index 40e470c36..1d05cb385 100644 --- a/examples/tutorial/7-composition/freuse_compositionScript.sml +++ b/examples/tutorial/7-composition/freuse_compositionScript.sml @@ -221,7 +221,7 @@ METIS_TAC [pred_setTheory.NOT_EQUAL_SETS] val assmpt = ct_assmpt; *) val bir_att_sec_add_ct = - bir_compose_seq_assmpt_predset simp_ct1 simp_ct2 [bprog_add_times_two_def, bir_att_sec_add_2_post_def, bir_att_sec_add_1_post_def] ct_assmpt; + bir_compose_seq_assmpt_predset simp_ct1 simp_ct2 [freuse_def, bir_att_sec_add_2_post_def, bir_att_sec_add_1_post_def] ct_assmpt; (* ====================================== *) diff --git a/examples/tutorial/7-composition/mutrec_compositionScript.sml b/examples/tutorial/7-composition/mutrec_compositionScript.sml index 4efce7a26..ece4c95e4 100644 --- a/examples/tutorial/7-composition/mutrec_compositionScript.sml +++ b/examples/tutorial/7-composition/mutrec_compositionScript.sml @@ -94,11 +94,12 @@ val bir_ieo_sec_isodd_exit_comp_ct = (bir_populate_blacklist_predset (REWRITE_RULE [GSYM abs_ev_intro, bir_ieo_sec_iseven_loop_post_def] loop_ev_simp_ct_2)); (* For debugging: - val loop_exit_simp_ct = loop_ev_exit_ht; + val loop_map_ct = loop_simp_ct; + val loop_exit_map_ct = loop_ev_exit_ht; val loop_invariant = ``bir_ieo_invariant v1``; val loop_condition = ``bir_ieo_condition``; val loop_variant = ``bir_ieo_variant``; - val prog_def = bprog_is_even_odd_def; + val prog_def = mutrec_def; val def_list = [bir_ieo_condition_def, bir_ieo_variant_def, bir_ieo_invariant_def, @@ -108,7 +109,7 @@ val bir_ieo_sec_isodd_exit_comp_ct = *) val loop_and_exit_ev_ht = bir_compose_simp_loop_unsigned_predset - loop_simp_ct loop_ev_exit_ht ``bir_ieo_invariant v1`` ``bir_ieo_condition`` ``bir_ieo_variant`` bprog_is_even_odd_def [bir_ieo_condition_def, + loop_simp_ct loop_ev_exit_ht ``bir_ieo_invariant v1`` ``bir_ieo_condition`` ``bir_ieo_variant`` mutrec_def [bir_ieo_condition_def, bir_ieo_variant_def, bir_ieo_invariant_def, bir_ieo_sec_iseven_loop_post_def, @@ -135,7 +136,7 @@ val loop_and_exit_ev_ht = *) val loop_and_exit_od_ht = bir_compose_simp_loop_unsigned_predset - loop_simp_ct loop_od_exit_ht ``bir_ieo_invariant v1`` ``bir_ieo_condition`` ``bir_ieo_variant`` bprog_is_even_odd_def [bir_ieo_condition_def, + loop_simp_ct loop_od_exit_ht ``bir_ieo_invariant v1`` ``bir_ieo_condition`` ``bir_ieo_variant`` mutrec_def [bir_ieo_condition_def, bir_ieo_variant_def, bir_ieo_invariant_def, bir_ieo_sec_isodd_loop_post_def, @@ -148,7 +149,7 @@ val loop_and_exit_od_ht = val is_even_1_ht = REWRITE_RULE [contract_ev_4_imp_taut_thm] (use_pre_str_rule_simp loop_and_exit_ev_ht contract_ev_4_imp_taut_thm); -val thm1 = ((Q.SPECL [`bprog_is_even_odd`, `bir_exp_true`, +val thm1 = ((Q.SPECL [`mutrec`, `bir_exp_true`, `BL_Address (Imm32 0w)`, `{BL_Address (Imm32 516w); BL_Address (Imm32 512w)}`, `{}`, `bir_ieo_pre v1`, `\l. if l = BL_Address (Imm32 0w) then bir_ieo_invariant v1 @@ -175,7 +176,7 @@ val bir_ieo_is_even_ht = save_thm("bir_ieo_is_even_ht", val is_odd_1_ht = REWRITE_RULE [contract_od_4_imp_taut_thm] (use_pre_str_rule_simp loop_and_exit_od_ht contract_od_4_imp_taut_thm); -val thm1 = ((Q.SPECL [`bprog_is_even_odd`, `bir_exp_true`, +val thm1 = ((Q.SPECL [`mutrec`, `bir_exp_true`, `BL_Address (Imm32 0x100w)`, `{BL_Address (Imm32 516w); BL_Address (Imm32 512w)}`, `{}`, `bir_ieo_pre v1`, `\l. diff --git a/examples/tutorial/test-composition.sml b/examples/tutorial/test-composition.sml index 7eecb21a0..2519fa927 100644 --- a/examples/tutorial/test-composition.sml +++ b/examples/tutorial/test-composition.sml @@ -3,10 +3,10 @@ open HolKernel Parse boolLib bossLib; val _ = Parse.current_backend := PPBackEnd.vt100_terminal; val _ = Globals.show_tags := true; -open tutorial_compositionTheory; +open add_reg_compositionTheory; open tutorial_backliftingTheory; -open tutorialExtra_compositionTheory; -open tutorialExtra2_compositionTheory; +open freuse_compositionTheory; +open mutrec_compositionTheory; fun print_and_check_thm name thm t_concl = let @@ -51,7 +51,7 @@ val _ = print_and_check_thm bir_att_ct `` bir_simp_jgmt - bprog_add_times_two + freuse bir_exp_true (BL_Address (Imm32 (0w :word32))) {BL_Address (Imm32 (8w :word32))} @@ -76,7 +76,7 @@ val _ = print_and_check_thm bir_ieo_is_even_ht `` bir_simp_jgmt - bprog_is_even_odd + mutrec bir_exp_true (BL_Address (Imm32 (0w :word32))) {BL_Address (Imm32 (516w :word32)); BL_Address (Imm32 (512w :word32))} @@ -89,7 +89,7 @@ val _ = print_and_check_thm bir_ieo_is_odd_ht `` bir_simp_jgmt - bprog_is_even_odd + mutrec bir_exp_true (BL_Address (Imm32 (256w :word32))) {BL_Address (Imm32 (516w :word32)); BL_Address (Imm32 (512w :word32))} diff --git a/src/tools/comp/bir_compositionLib.sml b/src/tools/comp/bir_compositionLib.sml index 77718941a..58422dd47 100644 --- a/src/tools/comp/bir_compositionLib.sml +++ b/src/tools/comp/bir_compositionLib.sml @@ -674,8 +674,8 @@ open bir_inst_liftingHelpersLib; FULL_SIMP_TAC (std_ss++abstract_hoare_logicSimps.bir_wm_SS) [bir_bool_expTheory.bir_is_bool_exp_env_def, bir_wm_instTheory.bir_etl_wm_def, bir_wm_instTheory.bir_weak_trs_def] >> Cases_on `bir_exec_to_labels - (^(pred_setSyntax.mk_set [start_label]) UNION (^wlist)) - (bprog_is_even_odd:'a bir_program_t) s` >> ( + (^(pred_setSyntax.mk_set [start_label]) UNION (^wlist)) + ((^prog):'a bir_program_t) s` >> ( FULL_SIMP_TAC (std_ss++HolBACoreSimps.holBACore_ss) [bir_programTheory.bir_exec_to_labels_def] ) >> IMP_RES_TAC bir_program_env_orderTheory.bir_exec_to_labels_n_ENV_ORDER >> From e095c81e21254bea29adb0e690bccf96f44a1584 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Mon, 26 Sep 2022 11:14:14 +0200 Subject: [PATCH 0119/1015] First version of BIR quotations library --- src/shared/bir_quotationLib.sml | 653 ++++++++++++++++++++++++++++++++ 1 file changed, 653 insertions(+) create mode 100644 src/shared/bir_quotationLib.sml diff --git a/src/shared/bir_quotationLib.sml b/src/shared/bir_quotationLib.sml new file mode 100644 index 000000000..1e4d67ea6 --- /dev/null +++ b/src/shared/bir_quotationLib.sml @@ -0,0 +1,653 @@ +structure bir_quotationLib = +struct + +open HolKernel Parse boolLib; + +open mlibParser mlibUseful; +open bslSyntax; +open bir_immSyntax; +open bir_expSyntax; +open bir_envSyntax; +open bir_valuesSyntax; +open bir_exp_immSyntax; + +infixr 8 ++ +infixr 7 >> +infixr 6 || + +(* error handling *) +val libname = "bir_quotationLib" +val ERR = Feedback.mk_HOL_ERR libname +val wrap_exn = Feedback.wrap_exn libname + +val default_size = 64; +val default_size_byte = 8; + +val expr_infixes : infixities ref = ref + [{tok = " / ", prec = 7, left_assoc = true}, + {tok = " % ", prec = 7, left_assoc = true}, + {tok = " * ", prec = 7, left_assoc = true}, + {tok = " + ", prec = 6, left_assoc = true}, + {tok = " - ", prec = 6, left_assoc = true}, + {tok = " & ", prec = 6, left_assoc = true}, + {tok = " ^ ", prec = 6, left_assoc = true}, + {tok = " | ", prec = 6, left_assoc = true}, + {tok = " << ", prec = 5, left_assoc = true}, + {tok = " >> ", prec = 5, left_assoc = true}, + {tok = " == ", prec = 4, left_assoc = true}, + {tok = " <> ", prec = 4, left_assoc = true}, + {tok = " <= ", prec = 4, left_assoc = true}, + {tok = " < ", prec = 4, left_assoc = true}, + {tok = " >= ", prec = 4, left_assoc = true}, + {tok = " > ", prec = 4, left_assoc = true}, + {tok = " : ", prec = 8, left_assoc = true} + ]; + +val reserved = ["(", ")", ".", "~", "assert", "assume", + "observe", "halt", "jmp", "cjmp", + "if", "then", "else"]; +val keywords = ["ld", "st", "chsign", "clz", "cls", + "ucast", "scast", "hcast", "lcast", + "sdiv", "smod"]; + +local + val initials = explode "_rxw"; +in + val var_string = ref (C mem initials o Char.toLower o hd o explode); +end; + +val lexer = + (fn ((_, (toks, _)), _) => toks) o + (many (some space) ++ + (many + ((((atleastone (some alphanum) || + (some (fn c => symbol c andalso c <> #"~") ++ many (some symbol)) >> + op ::) >> implode + || some (fn c => c = #"~" orelse punct c) >> str) ++ + many (some space)) >> fst)) ++ + finished); + + +val lex_str = lexer o mlibStream.from_list o explode; + +datatype fo_term = + Var of string + | Imm of string + | Fn of string * fo_term list; + +fun dest_imm (Imm n) = n + | dest_imm _ = raise Error "dest_imm: not an Imm" + +val is_imm = can dest_imm; + +fun dest_var (Var v) = v + | dest_var _ = raise Error "dest_var: not a Var" + +val is_var = can dest_var; + +fun dest_fn (Fn f) = f + | dest_fn _ = raise Error "dest_fn: not a Fn"; + +val is_fn = can dest_fn; + +val fn_name = fst o dest_fn; + +val fn_args = snd o dest_fn; + +val fn_arity = length o fn_args; + +fun fn_function tm = (fn_name tm, fn_arity tm); + +fun dest_const (Fn (c, [])) = c + | dest_const _ = raise Error "dest_const: not a const"; + +val is_const = can dest_const; + +fun dest_binop f (Fn (x, [a, b])) = + if x = f then (a, b) else raise Error "dest_binop: wrong binop" + | dest_binop _ _ = raise Error "dest_binop: not a binop"; + +fun is_binop f = can (dest_binop f); + +val vname_parser = some (fn tok => not (mem tok reserved) + andalso not (digit (hd (explode tok)))); + +val imm_parser = + some (fn tok => + let val cs = explode tok; + fun hex_digit c = + digit c + orelse + String.isSubstring (implode [(Char.toLower c)]) "abcdef"; + in + case cs of + #"0" :: #"x" ::rest => + List.all hex_digit rest + | _ => List.all digit cs + end + ); + +fun literal_from_string str = + if String.isPrefix "0x" str + then Arbnumcore.toInt (Arbnumcore.fromHexString str) + else valOf (Int.fromString str) + +val imm_term_parser = + let open wordsSyntax numSyntax; + fun to_term str = + mk_wordii (literal_from_string str, + 64); + in + (imm_parser >> (fn str => “Imm64 ^(to_term str)”) + handle Overflow => + raise (ERR "imm_term_parser" "integer overflow")) + end; + +fun term_parser ops = + let + val iparser = parse_infixes ops + val itoks = optoks ops + val avoid = itoks @ reserved + fun fname tok = mem tok keywords + val fname_parser = some fname + || (exact "(" ++ any ++ exact ")") >> (fst o snd) + fun basic inp = + ((exact "if" ++ tm_parser ++ exact "then" ++ tm_parser ++ exact "else" ++ tm_parser) >> (fn (_,(cond,(_,(left,(_,right))))) => + Fn ("__ite", [cond,left,right])) || + vname_parser >> Var || + imm_parser >> Imm || + fname_parser >> (fn f => Fn (f,[])) || + (exact "(" ++ tm_parser ++ exact ")") >> (fn (_,(t,_)) => t) + ) inp + and molecule inp = + ((many (exact "~") + ++ ((fname_parser ++ many basic) >> Fn || basic)) + >> (fn (l, t) => funpow (length l) + (fn x => Fn ("~", [x])) t)) inp + and tm_parser inp = + iparser (fn (f, a, b) => Fn (f, [a, b])) molecule inp + in + tm_parser + end; + +local + fun ty_to_int ty_str = + case ty_str of + "Bit8" => 8 + | "Bit16" => 16 + | "Bit32" => 32 + | "Bit64" => 64 + | _ => raise (ERR "ty_to_int" "invalid bit type") + fun lift n t = + case t of + Fn ("~", [a]) => + bnot (lift n a) + | Fn ("clz", [a]) => + bclz (lift n a) + | Fn ("cls", [a]) => + bcls (lift n a) + | Fn ("chsign", [a]) => + bchsign (lift n a) + | Fn ("+", [a,b]) => + bplus (lift n a, lift n b) + | Fn ("-", [a,b]) => + bminus (lift n a, lift n b) + | Fn ("*", [a,b]) => + bmult (lift n a, lift n b) + | Fn ("/", [a,b]) => + bdiv (lift n a, lift n b) + | Fn ("sdiv", [a,b]) => + bsdiv (lift n a, lift n b) + | Fn ("%", [a,b]) => + bmod (lift n a, lift n b) + | Fn ("smod", [a,b]) => + bsmod (lift n a, lift n b) + | Fn ("<<", [a,b]) => + blshift (lift n a, lift n b) + | Fn (">>", [a,b]) => + brshift (lift n a, lift n b) + | Fn ("ld", [a,b]) => + bloadi_le (lift_mem default_size default_size_byte a) + (lift default_size b) + default_size_byte + | Fn ("st", [a,b,c]) => + bstore_le (lift_mem default_size default_size_byte a) + (lift default_size b) + (lift n c) + | Fn ("==", [a,b]) => + beq (lift n a, lift n b) + | Fn ("<>", [a,b]) => + bneq (lift n a, lift n b) + | Fn ("<", [a,b]) => + blt (lift n a, lift n b) + | Fn (">", [a,b]) => + bgt (lift n a, lift n b) + | Fn ("<=", [a,b]) => + ble (lift n a, lift n b) + | Fn (">=", [a,b]) => + bge (lift n a, lift n b) + | Fn ("&", [a, b]) => + band (lift n a, lift n b) + | Fn ("|", [a,b]) => + bor (lift n a, lift n b) + | Fn ("^", [a,b]) => + bxor (lift n a, lift n b) + | Fn ("ucast", [a, Var ty]) => + bucasti (ty_to_int ty) (lift n a) + | Fn ("scast", [a, Var ty]) => + bscasti (ty_to_int ty) (lift n a) + | Fn ("hcast", [a, Var ty]) => + bhighcasti (ty_to_int ty) (lift n a) + | Fn ("lcast", [a, Var ty]) => + blowcasti (ty_to_int ty) (lift n a) + | Fn ("__ite", [cond,left,right]) => + bite (lift n cond, lift n left, lift n right) + | Fn (":", [a, Var ty]) => + lift (ty_to_int ty) a + | Var s => bden (bvarimm n s) + | Imm s => bconstii n (literal_from_string s) + handle Overflow => + raise (ERR "lift" "integer overflow") + and lift_mem n m (Var s) = bden (bvarmem (n,m) s) + | lift_mem n m t = lift n t +in +val bir_expr_parser = term_parser (!expr_infixes) >> lift 64; +end; + +fun string_to_term' ops = + fst o ((term_parser ops ++ finished) >> fst) o mlibStream.from_list o lex_str; +fun string_to_term s = string_to_term' (!expr_infixes) s; +val string_to_expr = + fst o ((bir_expr_parser ++ finished) >> fst) o mlibStream.from_list o lex_str; + +fun basic_stmt_parser obs_ty = + let + open bir_programSyntax numSyntax; + val hd_func = inst [Lib.|->(Type‘:'a’,obs_ty)] “HD”; + val obs_stmt_mono = + inst [Lib.|->(Type‘:'a’,obs_ty)] “BStmt_Observe”; + val parser = + (exact "assert" ++ bir_expr_parser) + >> (fn (_,exp) => bassert exp) || + (exact "assume" ++ bir_expr_parser) + >> (fn (_,exp) => bassume exp) || + (exact "observe" ++ imm_parser + ++ bir_expr_parser ++ bir_expr_parser) + >> (fn (_,(oid,(cnd,exp))) => + “^obs_stmt_mono (^(term_of_int (valOf (Int.fromString oid)))) ^cnd [^exp] ^hd_func”) || + (vname_parser ++ exact "=" ++ bir_expr_parser) + >> (fn (var,(_,exp)) => + let val lvalue = + if String.isPrefix "MEM" var + then bvarmem (default_size,default_size_byte) var + else bvarimm default_size var + in + bassign (lvalue,exp) + end + ) + in + parser >> inst [Lib.|->(Type‘:'a’,obs_ty)] + end; + +fun mklabel exp = + if is_BExp_Den exp + then + let val (var,ty) = dest_BVar_string (dest_BExp_Den exp) + in + belabel_str var + end + else if is_BExp_Const exp + then + let open wordsSyntax; + val (sz,c) = gen_dest_Imm (dest_BExp_Const exp) + in + belabel_addrii sz (uint_of_word c) + end + else + belabel_expr exp + +val end_stmt_parser = + ((exact "jmp" ++ bir_expr_parser) + >> (fn (_,exp) => bjmp (mklabel exp)) || + (exact "cjmp" ++ bir_expr_parser + ++ bir_expr_parser ++ bir_expr_parser) + >> (fn (_,(cnd,(left,right))) => + bcjmp (cnd, mklabel left, + mklabel right)) || + (exact "halt" ++ bir_expr_parser) + >> (fn (_,exp) => bhalt exp)) + +val parse_expr = + fst o ((bir_expr_parser ++ finished) >> fst); + +fun lift_parse p (inp: 'a stream stream) = + case inp of + mlibStream.NIL => raise mlibParser.Noparse + | mlibStream.CONS (s,ss) => + case p s of + (b,mlibStream.NIL) => (b,ss ()) + | _ => raise mlibParser.Noparse; + +fun bir_program_parser obs_ty = + let + open listSyntax; + val label_parser = + lift_parse ( + (((vname_parser >> blabel_str) + || (imm_term_parser >> blabel_addrimm)) + ++ exact ":" ++ finished) + >> (fn (t,_) => t) + ); + val stmt_parser = + lift_parse ((basic_stmt_parser obs_ty ++ finished) >> fst); + val end_stmt_parser_finished = + lift_parse ((end_stmt_parser ++ finished) >> fst); + fun block_parser inp = + ((label_parser + ++ many stmt_parser + ++ end_stmt_parser_finished) + >> (fn (lbl,(stmts,end_stmt)) + => bblock obs_ty (lbl, stmts, end_stmt))) + inp + fun prog_parser inp = + (many block_parser >> + (fn blocks => + case blocks of + [] => “BirProgram []” + | _ => “BirProgram ^(mk_list (blocks,type_of (List.hd blocks)))” + ))inp + in + prog_parser + end; + + +val line_tokenise = String.tokens (fn x => x = #"\n"); +val default_obs_ty = (Type`:bir_val_t`); +val parse_program = + fst o ((bir_program_parser default_obs_ty ++ finished) >> fst) + o (mlibStream.map (mlibStream.from_list o lex_str)) + o mlibStream.from_list o line_tokenise; + +val loc_parser = + (fn ((_,(_,(_,(line,(col,(_,_)))))),rest) + => (line,col,rest)) o + (exact "(" ++ + exact "*#" ++ + exact "loc" ++ + imm_parser ++ + imm_parser ++ + exact "*" ++ + exact ")"); + +val parse_loc = + loc_parser o mlibStream.from_list o lex_str + +fun BExp [QUOTE str] = + let val (line,col,body) = parse_loc str; + in + parse_expr body + handle e => + raise (wrap_exn + ("BExp (line "^line + ^", col "^col^")") e) + end; + +fun parse_loc_prog str = + let val first_line::lines = line_tokenise str; + val (line,col,body) = parse_loc first_line; + in + (line,col, + String.concatWith "\n" + (String.concatWith " " (mlibStream.to_list body) + :: lines)) + end; + +fun BIR [QUOTE str] = + let val (line,col,prog_body) = parse_loc_prog str; + in + parse_program prog_body + handle e => + raise (wrap_exn + ("BIR (line "^line + ^", col "^col^")") e) + end; + +val pp_vname = pp_string; + +fun pp_term' ops = + let + fun iprinter des = pp_infixes ops des + val itoks = optoks ops + fun specialf s = mem s itoks orelse !var_string s + val pp_fname = pp_map (fn s=>if specialf s then "("^s^")" else s) pp_string + fun idest (Fn (f, [a, b])) = SOME (f, a, b) | idest _ = NONE + fun is_op t = case idest t of SOME (f, _, _) => mem f itoks | NONE => false + fun negs (Fn ("~", [a])) = (curry op+ 1 ## I) (negs a) | negs tm = (0, tm) + open PP + fun basic (Var v) = pp_vname v + | basic (Imm v) = pp_string v + | basic (Fn ("__ite", [cond,left,right])) = + block INCONSISTENT 0 [ + add_string "if", add_break (1,0), + argument cond, add_break (1,0), + add_string "then", add_break (1,0), + argument left, add_break (1,0), + add_string "else", add_break (1,0), + argument right] + | basic (Fn (f, a)) = + block INCONSISTENT 0 + (pp_fname f :: + List.concat (map (fn x => [add_break (1,0), argument x]) a)) + and argument (tm: fo_term) = + if is_var tm orelse is_const tm orelse is_imm tm + then basic tm else pp_btm tm + and molecule (tm, r) = + let + val (n, x) = negs tm + in + block INCONSISTENT n [ + add_string (CharVector.tabulate(n, fn _ => #"~")), + if is_op x then pp_btm x else basic x + ] + end + and pp_btm tm = pp_bracket "(" ")" pp_tm (tm, false) + and pp_tm tmr = iprinter idest molecule tmr + in + pp_map (C pair false) pp_tm + end; + +local + open bir_expSyntax bir_immSyntax bir_valuesSyntax wordsSyntax; + open bir_exp_immSyntax; + fun immtype_to_string imm_type = + if is_Bit64 imm_type + then "Bit64" + else if is_Bit32 imm_type + then "Bit32" + else if is_Bit16 imm_type + then "Bit16" + else if is_Bit8 imm_type + then "Bit8" + else raise (ERR "immtype_to_string" "invalid imm type") + fun unop_to_string oper = + if is_BIExp_Not oper then "~" + else if is_BIExp_ChangeSign oper then "chsign" + else if is_BIExp_CLZ oper then "clz" + else if is_BIExp_CLS oper then "cls" + else raise (ERR "unop_to_string" "invalid unary op") + fun binop_to_string oper = + if is_BIExp_Plus oper then "+" + else if is_BIExp_Minus oper then "-" + else if is_BIExp_Mult oper then "*" + else if is_BIExp_Div oper then "/" + else if is_BIExp_SignedDiv oper then "sdiv" + else raise (ERR "binop_to_string" "invalid binop") + fun unlift_expr expr = + if is_BExp_Const expr + then let val (sz,c) = gen_dest_Imm (dest_BExp_Const expr) + val str = Int.toString (uint_of_word c) + in + if sz = 64 + then Imm str + else Fn (":", [Imm str, Var ("Bit"^Int.toString sz)]) + end + else if is_BExp_Den expr + then let val (var,ty) = dest_BVar_string (dest_BExp_Den expr) + in + if is_BType_Imm ty + then if is_BType_Imm64 ty + then Var var + else let val wty = dest_BType_Imm ty + in + Fn (":",[Var var, Var (immtype_to_string wty)]) + end + else Var var + end + else if is_BExp_UnaryExp expr + then let val (oper,a) = dest_BExp_UnaryExp expr + in + Fn (unop_to_string oper, [unlift_expr a]) + end + else if is_BExp_BinExp expr + then let val (oper,a,b) = dest_BExp_BinExp expr + in + Fn (binop_to_string oper, [unlift_expr a, unlift_expr b]) + end + else if is_BExp_BinPred expr + then let val (oper,a,b) = dest_BExp_BinPred expr + in + Fn (binop_to_string oper, [unlift_expr a, unlift_expr b]) + end + else if is_BExp_IfThenElse expr + then let val (cond,left,right) = dest_BExp_IfThenElse expr + in + Fn ("__ite", [unlift_expr cond, unlift_expr left, unlift_expr right]) + end + else + raise ERR "unlift_expr" "cannot pp this BExp" +in + fun pp_expr' ops = pp_map unlift_expr (pp_term' ops); +end; + +fun term_to_string' ops len tm = PP.pp_to_string len (pp_term' ops) tm; +fun expr_to_string' ops len fm = PP.pp_to_string len (pp_expr' ops) fm; + +(* Pretty-printing using !infixes and !LINE_LENGTH *) + +fun pp_term tm = pp_term' (!expr_infixes) tm; +fun pp_expr expr = pp_expr' (!expr_infixes) expr; +fun term_to_string tm = term_to_string' (!expr_infixes) (!LINE_LENGTH) tm; +fun expr_to_string expr = expr_to_string' (!expr_infixes) (!LINE_LENGTH) expr; + +local + open PP listSyntax; +in +fun pp_bracket pp tm = + if is_BLE_Label tm orelse is_BExp_Den tm orelse is_BExp_Const tm + then pp tm + else + block INCONSISTENT 0 [ + add_string "(", pp tm, add_string ")" + ]; +fun pp_bexpr expr = pp_bracket pp_expr expr; +fun pp_lbl lbl = + if is_BL_Label lbl + then PP.add_string (stringSyntax.fromHOLstring (dest_BL_Label lbl)) + else + let val (sz,c) = gen_dest_Imm (dest_BL_Address lbl) + in + PP.add_string (PolyML.makestring (wordsSyntax.uint_of_word c)) + end; +fun pp_lblexpr lblexpr = + if is_BLE_Label lblexpr + then let val lbl = dest_BLE_Label lblexpr + in + pp_lbl lbl + end + else + pp_expr (dest_BLE_Exp lblexpr) + +fun pp_app str pp = + block INCONSISTENT 0 [ + add_string str, add_break (1,0), + pp + ] + +fun pp_stmt stmt = + if is_BStmt_Assert stmt + then let val expr = dest_BStmt_Assert stmt + in + pp_app "assert" (pp_bexpr expr) + end + else if is_BStmt_Assume stmt + then let val expr = dest_BStmt_Assume stmt + in + pp_app "assume" (pp_bexpr expr) + end + else if is_BStmt_Assign stmt + then let open PP + val (var,expr) = dest_BStmt_Assign stmt + val (str,_) = dest_BVar_string var + in + block INCONSISTENT 0 [ + add_string str, add_break (1,0), + add_string "=", add_break (1,0), + pp_expr expr + ] + end + else if is_BStmt_Halt stmt + then let val expr = dest_BStmt_Halt stmt + in + pp_app "halt" (pp_bexpr expr) + end + else if is_BStmt_Jmp stmt + then let val lblexpr = dest_BStmt_Jmp stmt + in + pp_app "jmp" (pp_bracket pp_lblexpr lblexpr) + end + else if is_BStmt_CJmp stmt + then let val (cond,left,right) = dest_BStmt_CJmp stmt + in + block INCONSISTENT 0 [ + add_string "cjmp", add_break (1,0), + pp_bexpr cond, add_break (1,0), + pp_bracket pp_lblexpr left, add_break (1,0), + pp_bracket pp_lblexpr right + ] + end + else raise ERR "pp_stmt" "cannot pp this BIR statement" +fun pp_prog prog = + let val (block_list,_) = dest_list (dest_BirProgram prog) + fun pp_block bl = + let val (lbl,stmts_tm,end_stmt) = dest_bir_block bl + val (stmts,_) = dest_list stmts_tm; + in + PP.block INCONSISTENT 0 [ + pp_lbl lbl, add_string ":\n", + block INCONSISTENT 0 + (List.concat + (List.map (fn stmt => + [pp_stmt stmt, add_string "\n"]) stmts)), + pp_stmt end_stmt, add_string "\n" + ] + end + in + PP.block INCONSISTENT 0 + (List.map pp_block block_list) + end +end + + +val exp = BExp‘ucast (1 : Bit32) Bit8’ + +val prog = +BIR‘ +a: +assert (X1 + 0) +X1 = X2 + X4 +jmp b +b: +halt X1 +’; + +end From 86cb7145882aad967284692f79108bf02131e62f Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Mon, 26 Sep 2022 11:43:01 +0200 Subject: [PATCH 0120/1015] bir_quotationLib license --- src/shared/bir_quotationLib.sml | 48 ++++++++++++++++++++++++++++----- 1 file changed, 42 insertions(+), 6 deletions(-) diff --git a/src/shared/bir_quotationLib.sml b/src/shared/bir_quotationLib.sml index 1e4d67ea6..ad9bcb35a 100644 --- a/src/shared/bir_quotationLib.sml +++ b/src/shared/bir_quotationLib.sml @@ -1,3 +1,38 @@ +(* +BIR quotation parser for HolBA +============================== + +Based on mlibTerm in HOL4's metis implementation by Joe Hurd. + +This library is released under the standard BSD-3-Clause license. + +Copyright 2022 Pablo Buiras + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation and/or +other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) structure bir_quotationLib = struct @@ -60,11 +95,12 @@ val lexer = (fn ((_, (toks, _)), _) => toks) o (many (some space) ++ (many - ((((atleastone (some alphanum) || - (some (fn c => symbol c andalso c <> #"~") ++ many (some symbol)) >> - op ::) >> implode - || some (fn c => c = #"~" orelse punct c) >> str) ++ - many (some space)) >> fst)) ++ + ((((atleastone (some alphanum) || + (some (fn c => symbol c andalso c <> #"~") ++ + many (some symbol)) >> + op ::) >> implode + || some (fn c => c = #"~" orelse punct c) >> str) ++ + many (some space)) >> fst)) ++ finished); @@ -540,7 +576,7 @@ fun term_to_string tm = term_to_string' (!expr_infixes) (!LINE_LENGTH) tm; fun expr_to_string expr = expr_to_string' (!expr_infixes) (!LINE_LENGTH) expr; local - open PP listSyntax; + open PP listSyntax bir_programSyntax; in fun pp_bracket pp tm = if is_BLE_Label tm orelse is_BExp_Den tm orelse is_BExp_Const tm From 8bf5639d188fe1c2ab5080ebe732acc472b76915 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Mon, 26 Sep 2022 16:27:11 +0200 Subject: [PATCH 0121/1015] signature file --- src/shared/bir_quotationLib.sig | 55 +++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 src/shared/bir_quotationLib.sig diff --git a/src/shared/bir_quotationLib.sig b/src/shared/bir_quotationLib.sig new file mode 100644 index 000000000..84593ce69 --- /dev/null +++ b/src/shared/bir_quotationLib.sig @@ -0,0 +1,55 @@ +(* +BIR quotation library for HolBA +=============================== +This library is released under the standard BSD-3-Clause license. +See .sml file for more docs. + +Copyright 2022 Pablo Buiras + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation and/or +other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*) +signature bir_quotationLib = +sig + include Abbrev + + (* Set the following refs to alter memory defaults *) + (* default = 64 *) + val quotation_default_size : int ref + + (* default = 8 *) + val quotation_default_size_byte : int ref + + (* default=["MEM","_MEM"] *) + val quotation_memory_prefixes : string list ref + + (* Parsers *) + val BExp : 'a frag list -> term + val BIR : 'a frag list -> term + + (* Pretty printers *) + val expr_to_string : term -> string + val prog_to_string : term -> string +end From 1982b9104668e9baf571f02be472b0ed19c703e3 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Mon, 26 Sep 2022 16:28:07 +0200 Subject: [PATCH 0122/1015] added new ldX, stX forms; semi-finished pretty printer --- src/shared/bir_quotationLib.sml | 180 ++++++++++++++++++++++++++++---- 1 file changed, 158 insertions(+), 22 deletions(-) diff --git a/src/shared/bir_quotationLib.sml b/src/shared/bir_quotationLib.sml index ad9bcb35a..59da51013 100644 --- a/src/shared/bir_quotationLib.sml +++ b/src/shared/bir_quotationLib.sml @@ -1,9 +1,39 @@ (* -BIR quotation parser for HolBA -============================== +BIR quotation library for HolBA +=============================== Based on mlibTerm in HOL4's metis implementation by Joe Hurd. +The reference expr_infixes contains infix operator precedence and associativity. +Should be easy to change to suit your needs. + +Known issues and limitations: + +- Antiquoting is not supported. Unfortunately this hinders usability in proofs. + It could be implemented but it's a lot more work and requires a complete + pretty printer. + +- When a jump target is a string, it is interpreted as a static string label. + This means the following program may not parse as one expects: + +val not_indirect_jump = BIR‘ +a: + X1 = 0x8000004 + jmp X1 +’ + + The jump becomes a direct jump to a non-existing label X1. In order to express + an indirect jump properly we need to force the parser to interpret the jump + target as an expression, as follows: + +val indirect_jump = BIR‘ +a: + X1 = 0x8000004 + jmp (X1+0) +’ + +- Error reporting is very limited. + This library is released under the standard BSD-3-Clause license. Copyright 2022 Pablo Buiras @@ -33,7 +63,7 @@ ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *) -structure bir_quotationLib = +structure bir_quotationLib :> bir_quotationLib = struct open HolKernel Parse boolLib; @@ -55,8 +85,9 @@ val libname = "bir_quotationLib" val ERR = Feedback.mk_HOL_ERR libname val wrap_exn = Feedback.wrap_exn libname -val default_size = 64; -val default_size_byte = 8; +val quotation_default_size = ref 64; +val quotation_default_size_byte = ref 8; +val quotation_memory_prefixes = ref ["MEM", "_MEM"]; val expr_infixes : infixities ref = ref [{tok = " / ", prec = 7, left_assoc = true}, @@ -81,9 +112,11 @@ val expr_infixes : infixities ref = ref val reserved = ["(", ")", ".", "~", "assert", "assume", "observe", "halt", "jmp", "cjmp", "if", "then", "else"]; -val keywords = ["ld", "st", "chsign", "clz", "cls", +val keywords = ["ld", "ld8", "ld16", "ld32", "ld64", + "st", "st8", "st16", "st32", "st64", + "chsign", "clz", "cls", "ucast", "scast", "hcast", "lcast", - "sdiv", "smod"]; + "sdiv", "smod", "srsh", "slt", "sle", "memeq"]; local val initials = explode "_rxw"; @@ -111,6 +144,10 @@ datatype fo_term = | Imm of string | Fn of string * fo_term list; +fun is_memory_var s = + List.exists (fn prefix => String.isPrefix prefix s) + (!quotation_memory_prefixes); + fun dest_imm (Imm n) = n | dest_imm _ = raise Error "dest_imm: not an Imm" @@ -146,7 +183,8 @@ fun dest_binop f (Fn (x, [a, b])) = fun is_binop f = can (dest_binop f); val vname_parser = some (fn tok => not (mem tok reserved) - andalso not (digit (hd (explode tok)))); + andalso not (digit (hd (explode tok))) + andalso not (mem tok (optoks (!expr_infixes)))); val imm_parser = some (fn tok => @@ -184,9 +222,9 @@ fun term_parser ops = val iparser = parse_infixes ops val itoks = optoks ops val avoid = itoks @ reserved - fun fname tok = mem tok keywords + fun fname tok = mem tok keywords andalso not (mem tok avoid) val fname_parser = some fname - || (exact "(" ++ any ++ exact ")") >> (fst o snd) + || (exact "(" ++ any ++ exact ")") >> (fst o snd) fun basic inp = ((exact "if" ++ tm_parser ++ exact "then" ++ tm_parser ++ exact "else" ++ tm_parser) >> (fn (_,(cond,(_,(left,(_,right))))) => Fn ("__ite", [cond,left,right])) || @@ -238,28 +276,68 @@ local bmod (lift n a, lift n b) | Fn ("smod", [a,b]) => bsmod (lift n a, lift n b) + | Fn ("srsh", [a,b]) => + bsrshift (lift n a, lift n b) | Fn ("<<", [a,b]) => blshift (lift n a, lift n b) | Fn (">>", [a,b]) => brshift (lift n a, lift n b) | Fn ("ld", [a,b]) => - bloadi_le (lift_mem default_size default_size_byte a) - (lift default_size b) - default_size_byte + bloadi_le (lift n a) + (lift (!quotation_default_size) b) + n + | Fn ("ld8", [a,b]) => + bloadi_le (lift n a) + (lift (!quotation_default_size) b) + 8 + | Fn ("ld16", [a,b]) => + bloadi_le (lift n a) + (lift (!quotation_default_size) b) + 16 + | Fn ("ld32", [a,b]) => + bloadi_le (lift n a) + (lift (!quotation_default_size) b) + 32 + | Fn ("ld64", [a,b]) => + bloadi_le (lift n a) + (lift (!quotation_default_size) b) + 64 | Fn ("st", [a,b,c]) => - bstore_le (lift_mem default_size default_size_byte a) - (lift default_size b) + bstore_le (lift n a) + (lift (!quotation_default_size) b) (lift n c) + | Fn ("st8", [a,b,c]) => + bstore_le (lift n a) + (lift (!quotation_default_size) b) + (lift 8 c) + | Fn ("st16", [a,b,c]) => + bstore_le (lift n a) + (lift (!quotation_default_size) b) + (lift 16 c) + | Fn ("st32", [a,b,c]) => + bstore_le (lift n a) + (lift (!quotation_default_size) b) + (lift 32 c) + | Fn ("st64", [a,b,c]) => + bstore_le (lift n a) + (lift (!quotation_default_size) b) + (lift 64 c) | Fn ("==", [a,b]) => beq (lift n a, lift n b) + | Fn ("memeq", [a,b]) => + bmemeq (lift n a, lift n b) | Fn ("<>", [a,b]) => bneq (lift n a, lift n b) | Fn ("<", [a,b]) => blt (lift n a, lift n b) + | Fn ("slt", [a,b]) => + bslt (lift n a, lift n b) | Fn (">", [a,b]) => bgt (lift n a, lift n b) | Fn ("<=", [a,b]) => ble (lift n a, lift n b) + | Fn ("sle", [a,b]) => + bsle (lift n a, lift n b) | Fn (">=", [a,b]) => bge (lift n a, lift n b) | Fn ("&", [a, b]) => @@ -280,12 +358,19 @@ local bite (lift n cond, lift n left, lift n right) | Fn (":", [a, Var ty]) => lift (ty_to_int ty) a - | Var s => bden (bvarimm n s) + | Fn (fname, args) => + raise ERR "lift" + ("parse error in function application: " + ^ fname ^ ", arguments: " ^ PolyML.makestring args) + | Var s => + if is_memory_var s + then + bden (bvarmem ((!quotation_default_size) + ,(!quotation_default_size_byte)) s) + else bden (bvarimm n s) | Imm s => bconstii n (literal_from_string s) handle Overflow => raise (ERR "lift" "integer overflow") - and lift_mem n m (Var s) = bden (bvarmem (n,m) s) - | lift_mem n m t = lift n t in val bir_expr_parser = term_parser (!expr_infixes) >> lift 64; end; @@ -315,8 +400,8 @@ fun basic_stmt_parser obs_ty = >> (fn (var,(_,exp)) => let val lvalue = if String.isPrefix "MEM" var - then bvarmem (default_size,default_size_byte) var - else bvarimm default_size var + then bvarmem (!quotation_default_size,!quotation_default_size_byte) var + else bvarimm (!quotation_default_size) var in bassign (lvalue,exp) end @@ -495,6 +580,16 @@ fun pp_term' ops = local open bir_expSyntax bir_immSyntax bir_valuesSyntax wordsSyntax; open bir_exp_immSyntax; + fun ty_to_string imm_type = + if is_Bit64 imm_type + then "64" + else if is_Bit32 imm_type + then "32" + else if is_Bit16 imm_type + then "16" + else if is_Bit8 imm_type + then "8" + else raise (ERR "immtype_to_string" "invalid imm type") fun immtype_to_string imm_type = if is_Bit64 imm_type then "Bit64" @@ -517,6 +612,24 @@ local else if is_BIExp_Mult oper then "*" else if is_BIExp_Div oper then "/" else if is_BIExp_SignedDiv oper then "sdiv" + else if is_BIExp_And oper then "&" + else if is_BIExp_Or oper then "|" + else if is_BIExp_Xor oper then "^" + else if is_BIExp_Mod oper then "%" + else if is_BIExp_SignedMod oper then "smod" + else if is_BIExp_LeftShift oper then "<<" + else if is_BIExp_RightShift oper then ">>" + else if is_BIExp_SignedRightShift oper then "srsh" + else if is_BIExp_Equal oper then "==" + else if is_BIExp_NotEqual oper then "<>" + else if is_BIExp_LessThan oper then "<" + else if is_BIExp_LessOrEqual oper then "<=" + else if is_BIExp_SignedLessThan oper then "slt" + else if is_BIExp_SignedLessOrEqual oper then "sle" + else if is_BIExp_UnsignedCast oper then "ucast" + else if is_BIExp_SignedCast oper then "scast" + else if is_BIExp_HighCast oper then "hcast" + else if is_BIExp_LowCast oper then "lcast" else raise (ERR "binop_to_string" "invalid binop") fun unlift_expr expr = if is_BExp_Const expr @@ -559,6 +672,26 @@ local in Fn ("__ite", [unlift_expr cond, unlift_expr left, unlift_expr right]) end + else if is_BExp_MemEq expr + then let val (a,b) = dest_BExp_MemEq expr + in + Fn ("memeq", [unlift_expr a, unlift_expr b]) + end + else if is_BExp_Load expr + then let val (mem,addr,_,sz) = dest_BExp_Load expr + in + Fn ("ld" ^ (ty_to_string sz), [unlift_expr mem, unlift_expr addr]) + end + else if is_BExp_Store expr + then let val (mem,addr,_,value) = dest_BExp_Store expr + in + Fn ("st", [unlift_expr mem, unlift_expr addr, unlift_expr value]) + end + else if is_BExp_Cast expr + then let val (a,b,c) = dest_BExp_Cast expr + in + Fn (binop_to_string a, [unlift_expr b, Var (immtype_to_string c)]) + end else raise ERR "unlift_expr" "cannot pp this BExp" in @@ -673,14 +806,17 @@ fun pp_prog prog = end end +fun prog_to_string' len fm = PP.pp_to_string len pp_prog fm; +fun prog_to_string prog = prog_to_string' (!LINE_LENGTH) prog; +(* Some examples *) val exp = BExp‘ucast (1 : Bit32) Bit8’ val prog = BIR‘ a: -assert (X1 + 0) -X1 = X2 + X4 +assert (X1 > 0) +X1 = sdiv X2 4 + ld MEM X4 + 3 jmp b b: halt X1 From b96c2433d62808c21efbc5bfc3d0539ac4dd2533 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Wed, 28 Sep 2022 10:16:13 +0200 Subject: [PATCH 0123/1015] comment syntax --- src/shared/bir_quotationLib.sml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/shared/bir_quotationLib.sml b/src/shared/bir_quotationLib.sml index 59da51013..a5acd7695 100644 --- a/src/shared/bir_quotationLib.sml +++ b/src/shared/bir_quotationLib.sml @@ -139,6 +139,10 @@ val lexer = val lex_str = lexer o mlibStream.from_list o explode; +fun filter_comment [] = [] + | filter_comment (";" :: ts) = [] + | filter_comment (tok :: ts) = tok :: filter_comment ts + datatype fo_term = Var of string | Imm of string @@ -486,7 +490,7 @@ val line_tokenise = String.tokens (fn x => x = #"\n"); val default_obs_ty = (Type`:bir_val_t`); val parse_program = fst o ((bir_program_parser default_obs_ty ++ finished) >> fst) - o (mlibStream.map (mlibStream.from_list o lex_str)) + o (mlibStream.map (mlibStream.from_list o filter_comment o lex_str)) o mlibStream.from_list o line_tokenise; val loc_parser = @@ -815,7 +819,7 @@ val exp = BExp‘ucast (1 : Bit32) Bit8’ val prog = BIR‘ a: -assert (X1 > 0) +assert (X1 > 0) ; this is a comment X1 = sdiv X2 4 + ld MEM X4 + 3 jmp b b: From 5f4db5efa4501f8cddb821141d18aa0fa6db0d9b Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Wed, 28 Sep 2022 11:31:21 +0200 Subject: [PATCH 0124/1015] fixes --- src/shared/bir_quotationLib.sml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/shared/bir_quotationLib.sml b/src/shared/bir_quotationLib.sml index a5acd7695..53d4bb779 100644 --- a/src/shared/bir_quotationLib.sml +++ b/src/shared/bir_quotationLib.sml @@ -10,8 +10,7 @@ Should be easy to change to suit your needs. Known issues and limitations: - Antiquoting is not supported. Unfortunately this hinders usability in proofs. - It could be implemented but it's a lot more work and requires a complete - pretty printer. + It could be implemented but it's a lot more work. - When a jump target is a string, it is interpreted as a static string label. This means the following program may not parse as one expects: @@ -485,12 +484,19 @@ fun bir_program_parser obs_ty = prog_parser end; - val line_tokenise = String.tokens (fn x => x = #"\n"); val default_obs_ty = (Type`:bir_val_t`); val parse_program = fst o ((bir_program_parser default_obs_ty ++ finished) >> fst) - o (mlibStream.map (mlibStream.from_list o filter_comment o lex_str)) + o (mlibStream.partial_map + (fn line => + let val tokens = filter_comment (lex_str line) + in + if null tokens + then NONE + else SOME (mlibStream.from_list tokens) + end) + ) o mlibStream.from_list o line_tokenise; val loc_parser = From 5682c55b14899a6a15f37b88963b9e693060fce9 Mon Sep 17 00:00:00 2001 From: Pablo Buiras Date: Wed, 28 Sep 2022 11:33:48 +0200 Subject: [PATCH 0125/1015] BIR grammar and quotation library docs --- src/shared/bir_grammar/bir_grammar.tex | 202 +++++++++++++++++++++++++ 1 file changed, 202 insertions(+) create mode 100644 src/shared/bir_grammar/bir_grammar.tex diff --git a/src/shared/bir_grammar/bir_grammar.tex b/src/shared/bir_grammar/bir_grammar.tex new file mode 100644 index 000000000..7922e3210 --- /dev/null +++ b/src/shared/bir_grammar/bir_grammar.tex @@ -0,0 +1,202 @@ +\documentclass{article} +\usepackage{syntax} + +\begin{document} +\section{BIR syntax} + +\begin{itemize} +\item \syntax{} is a numeric literal, either in decimal notation (e.g. 123) +or in hexadecimal (e.g. 0xabc). + +\item \syntax{} is a variable name. + +\item Variables that begin with the prefix ``MEM'' will be parsed as memory + variables of default memory type; these are the only allowed memory variables, + and they cannot be treated as registers. Any keywords that appear in the + grammar below are reserved and cannot occur as variables. The string ``__ite'' + is also reserved and used internally by the parser. +\end{itemize} + +\setlength{\grammarparsep}{4pt plus 1pt minus 1pt} % increase separation between rules +\setlength{\grammarindent}{12em} % increase separation between LHS/RHS + +\begin{grammar} + + ::= Bit8 | Bit16 | Bit32 | Bit64 + + ::= ucast | scast | hcast | lcast + + ::= chsign | cls | clz + + ::= + | - | * | / | \% | $\ll$ | $\gg$ | == | ... + + ::= sdiv | smod | memeq | srsh | slt | sle + + ::= \alt + \alt \textasciitilde + \alt + \alt + \alt + \alt ld + \alt ld\{8,16,32,64\} + \alt st + \alt st\{8,16,32,64\} + \alt + \alt if then else + \alt : + + ::= assert + \alt assume + \alt observe + \alt = + + ::= halt + \alt jmp + \alt cjmp + + ::= `\\n' | + +